From ffjeld at common-lisp.net Thu Apr 1 02:09:27 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 31 Mar 2004 21:09:27 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv20779 Modified Files: compiler.lisp Log Message: These changes are mostly about being more consistent about using ECX as a scratch (non-GC-root) register. Date: Wed Mar 31 21:09:26 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.39 movitz/compiler.lisp:1.40 --- movitz/compiler.lisp:1.39 Wed Mar 31 10:55:31 2004 +++ movitz/compiler.lisp Wed Mar 31 21:09:26 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.39 2004/03/31 15:55:31 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.40 2004/04/01 02:09:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2095,8 +2095,8 @@ (binding-name object) (unless (eq object (binding-target object)) (binding-name (binding-target object))) - (when (and (slot-exists-p object 'store-type) - (slot-boundp object 'store-type) + (when (and #+ignore (slot-exists-p object 'store-type) + #+ignore (slot-boundp object 'store-type) (binding-store-type object)) (apply #'encoded-type-decode (binding-store-type object))))))) @@ -2107,6 +2107,9 @@ :reader constant-object))) (defmethod binding-lended-p ((binding constant-object-binding)) nil) +(defmethod binding-store-type ((binding constant-object-binding)) + (multiple-value-list (type-specifier-encode `(eql ,(constant-object binding))))) + (defclass operator-binding (binding) ()) @@ -2430,7 +2433,7 @@ pos))))) (defun compute-free-registers (pc distance funobj frame-map - &key (free-registers '(:eax :ebx :edx))) + &key (free-registers '(:eax :ebx :ecx :edx))) "Return set of free register, and whether there may be more registers free later, with a more specified frame-map." (loop with free-so-far = free-registers @@ -2515,16 +2518,22 @@ (distance (position load-instruction (cdr init-pc)))) (multiple-value-bind (free-registers more-later-p) (and distance (compute-free-registers (cdr init-pc) distance funobj frame-map)) - (cond - ((member binding-destination free-registers) - binding-destination) - ((member init-with-register free-registers) - init-with-register) - ((not (null free-registers)) - (first free-registers)) - (more-later-p - (values nil :not-now)) - (t (values nil :never))))))) + (if (and (member :ecx free-registers) + (not (typep binding 'function-argument)) + (or (eq :untagged-fixnum-ecx binding-destination) + (eq :untagged-fixnum-ecx init-with-register))) + :untagged-fixnum-ecx + (let ((free-registers (remove :ecx free-registers))) + (cond + ((member binding-destination free-registers) + binding-destination) + ((member init-with-register free-registers) + init-with-register) + ((not (null free-registers)) + (first free-registers)) + (more-later-p + (values nil :not-now)) + (t (values nil :never))))))))) (t (values nil :never))))) (defun discover-variables (code function-env) @@ -3000,6 +3009,14 @@ &key tmp-register protect-registers) "When tmp-register is provided, use that for intermediate storage required when loading borrowed bindings." + #+ignore + (when (eq :ecx result-mode) + ;; (warn "loading to ecx: ~S" binding) + (unless (or (null (binding-store-type binding)) + (movitz-subtypep (apply #'encoded-type-decode + (binding-store-type binding)) + 'integer)) + (warn "ecx from ~S" binding))) (when (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding)) (warn "The variable ~S is used even if it was declared ignored." (binding-name binding))) @@ -3012,32 +3029,56 @@ protect-registers)) (error "Unable to chose a temporary register."))) (install-for-single-value (lexb lexb-location result-mode indirect-p) - (if (integerp lexb-location) - (append `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location)) - ,(single-value-register result-mode))) - (when indirect-p - `((:movl (-1 ,(single-value-register result-mode)) - ,(single-value-register result-mode))))) - (ecase lexb-location - (:eax - (assert (not indirect-p)) - (ecase result-mode - ((:ebx :ecx :edx :esi) `((:movl :eax ,result-mode))) - ((:eax :single-value) nil))) - ((:ebx :ecx :edx) - (assert (not indirect-p)) - (unless (eq result-mode lexb-location) + (cond + ((and (eq result-mode :untagged-fixnum-ecx) + (integerp lexb-location)) + (assert (not indirect-p)) + `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location)) + :ecx) + (:sarl ,+movitz-fixnum-shift+ :ecx))) + ((integerp lexb-location) + (append `((:movl ,(make-indirect-reference :ebp (stack-frame-offset lexb-location)) + ,(single-value-register result-mode))) + (when indirect-p + `((:movl (-1 ,(single-value-register result-mode)) + ,(single-value-register result-mode)))))) + (t (ecase lexb-location + (:eax + (assert (not indirect-p)) (ecase result-mode - ((:eax :single-value) `((:movl ,lexb-location :eax))) - ((:ebx :ecx :edx :esi) `((:movl ,lexb-location ,result-mode)))))) - (:argument-stack - (assert (<= 2 (function-argument-argnum lexb)) () - "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb)) - (append `((:movl (:ebp ,(argument-stack-offset lexb)) - ,(single-value-register result-mode))) - (when indirect-p - `((:movl (-1 ,(single-value-register result-mode)) - ,(single-value-register result-mode)))))))))) + ((:ebx :ecx :edx :esi) `((:movl :eax ,result-mode))) + ((:eax :single-value) nil) + (:untagged-fixnum-ecx + `((:movl :eax :ecx) + (:sarl ,movitz:+movitz-fixnum-factor+ :ecx))))) + ((:ebx :ecx :edx) + (assert (not indirect-p)) + (unless (eq result-mode lexb-location) + (ecase result-mode + ((:eax :single-value) `((:movl ,lexb-location :eax))) + ((:ebx :ecx :edx :esi) `((:movl ,lexb-location ,result-mode))) + (:untagged-fixnum-ecx + `((:movl ,lexb-location :ecx) + (:sarl ,movitz:+movitz-fixnum-factor+ :ecx)))))) + (:argument-stack + (assert (<= 2 (function-argument-argnum lexb)) () + "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb)) + (cond + ((eq result-mode :untagged-fixnum-ecx) + (assert (not indirect-p)) + `((:movl (:ebp ,(argument-stack-offset lexb)) :ecx) + (:sarl ,+movitz-fixnum-shift+ :ecx))) + (t (append `((:movl (:ebp ,(argument-stack-offset lexb)) + ,(single-value-register result-mode))) + (when indirect-p + `((:movl (-1 ,(single-value-register result-mode)) + ,(single-value-register result-mode)))))))) + (:untagged-fixnum-ecx + (ecase result-mode + ((:eax :ebx :ecx :edx) + `((:leal ((:ecx ,+movitz-fixnum-factor+)) ,result-mode))) + (:untagged-fixnum-ecx + nil)))))))) (etypecase binding (forwarding-binding (assert (not (binding-lended-p binding)) (binding) @@ -3138,9 +3179,7 @@ `((:cmpl :edi (:ebp ,(argument-stack-offset binding))) (:je ',(operands result-mode))))))) (:untagged-fixnum-ecx - (make-result-and-returns-glue - result-mode :ecx - (install-for-single-value binding binding-location :ecx nil))) + (install-for-single-value binding binding-location :untagged-fixnum-ecx nil)) (:lexical-binding (let* ((destination result-mode) (dest-location (new-binding-location destination frame-map :default nil))) @@ -3174,6 +3213,13 @@ "funny binding: ~W" binding) (let ((protect-registers (cons source protect-registers))) (cond + ((eq :untagged-fixnum-ecx source) + (if (eq :untagged-fixnum-ecx + (new-binding-location binding frame-map)) + nil + (append (make-result-and-returns-glue :ecx :untagged-fixnum-ecx) + (make-store-lexical binding :ecx shared-reference-p frame-map + :protect-registers protect-registers)))) ((typep binding 'borrowed-binding) (let ((slot (borrowed-binding-reference-slot binding))) (if (not shared-reference-p) @@ -3214,7 +3260,12 @@ (:argument-stack (assert (<= 2 (function-argument-argnum binding)) () "store-lexical argnum can't be ~A." (function-argument-argnum binding)) - `((:movl ,source (:ebp ,(argument-stack-offset binding)))))))))))) + `((:movl ,source (:ebp ,(argument-stack-offset binding))))) + (:untagged-fixnum-ecx + (append (unless (member source '(:ecx :untagged-fixnum-ecx)) + `((:movl ,source :ecx))) + (unless (eq source :untagged-fixnum-ecx) + `((:sarl ,+movitz-fixnum-shift+ :ecx)))))))))))) (defun finalize-code (code funobj frame-map) ;; (print-code 'to-be-finalized code) @@ -4631,7 +4682,10 @@ (:untagged-fixnum-ecx (case (result-mode-type desired-result) ((:eax :ebx :ecx :edx) - (values (append code `((:leal ((:ecx ,+movitz-fixnum-factor+) :edi ,(edi-offset)) + (values (append code `((:cmpl ,+movitz-most-positive-fixnum+ :ecx) + (:ja '(:sub-program () + (:int 4))) + (:leal ((:ecx ,+movitz-fixnum-factor+) :edi ,(edi-offset)) ,desired-result))) desired-result)) (t (make-result-and-returns-glue desired-result :eax @@ -4695,7 +4749,7 @@ (compiler-call #'compile-form :result-mode :ebx :forward form-info)) - ((member form-returns '(:eax :ebx :ecx :edx :edi)) + ((member form-returns '(:eax :ebx :ecx :edx :edi :untagged-fixnum-ecx)) (compiler-values (unprotected-values))) (t (compiler-call #'compile-form :result-mode :eax From ffjeld at common-lisp.net Thu Apr 1 02:09:58 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 31 Mar 2004 21:09:58 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20939 Modified Files: arrays.lisp Log Message: Minor edit. Date: Wed Mar 31 21:09:58 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.15 movitz/losp/muerte/arrays.lisp:1.16 --- movitz/losp/muerte/arrays.lisp:1.15 Wed Mar 31 11:39:38 2004 +++ movitz/losp/muerte/arrays.lisp Wed Mar 31 21:09:58 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.15 2004/03/31 16:39:38 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.16 2004/04/01 02:09:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -106,7 +106,7 @@ (defun fill-pointer (vector) (check-type vector vector) - (memref vector #.(bt:slot-offset 'movitz::movitz-vector 'movitz::fill-pointer) 0 + (memref vector #.(bt:slot-offset 'movitz:movitz-vector 'movitz::fill-pointer) 0 :unsigned-byte16)) From ffjeld at common-lisp.net Thu Apr 1 02:10:39 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 31 Mar 2004 21:10:39 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv960 Modified Files: basic-functions.lisp Log Message: Prefer EDX over ECX as temporary register. Date: Wed Mar 31 21:10:38 2004 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.8 movitz/losp/muerte/basic-functions.lisp:1.9 --- movitz/losp/muerte/basic-functions.lisp:1.8 Mon Mar 29 09:32:40 2004 +++ movitz/losp/muerte/basic-functions.lisp Wed Mar 31 21:10:38 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.8 2004/03/29 14:32:40 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.9 2004/04/01 02:10:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -117,12 +117,13 @@ (:call (:esi #.(movitz::slot-offset 'movitz::movitz-funobj 'movitz::code-vector%2op))))) ((not (next x)) ; 3 args (with-inline-assembly (:returns :multiple-values) - (:compile-form (:result-mode :ecx) args) - (:movl (:ecx -1) :eax) ; arg0 - (:movl (:ecx 3) :ecx) ; ecx = (cdr ebx) - (:movl (:ecx -1) :ebx) ; ecx = (car ebx) = arg1 - (:movl (:ecx 3) :ecx) ; ecx = (cdr ebx) - (:pushl (:ecx -1)) ; arg2 + (:compile-form (:result-mode :edx) args) + (:movl (:edx -1) :eax) ; arg0 + (:movl (:edx 3) :edx) ; edx = (cdr ebx) + (:movl (:edx -1) :ebx) ; edx = (car ebx) = arg1 + (:movl (:edx 3) :edx) ; edx = (cdr ebx) + (:pushl (:edx -1)) ; arg2 + (:compile-form (:result-mode :edx) function-or-name) (:compile-form (:result-mode :esi) function) (:call (:esi #.(movitz::slot-offset 'movitz::movitz-funobj 'movitz::code-vector%3op))))) (t (with-inline-assembly (:returns :multiple-values) From ffjeld at common-lisp.net Thu Apr 1 02:11:48 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 31 Mar 2004 21:11:48 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5750 Modified Files: inspect.lisp Log Message: Minor code-tuneup. Date: Wed Mar 31 21:11:48 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.6 movitz/losp/muerte/inspect.lisp:1.7 --- movitz/losp/muerte/inspect.lisp:1.6 Mon Mar 29 10:26:25 2004 +++ movitz/losp/muerte/inspect.lisp Wed Mar 31 21:11:48 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.6 2004/03/29 15:26:25 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.7 2004/04/01 02:11:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -87,8 +87,9 @@ (defun stack-ref-p (pointer) (let ((top (load-global-constant-u32 stack-top)) - (bottom (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:movl :esp :ecx)))) + (bottom (with-inline-assembly (:returns :eax) + (:movl :esp :eax) + (:shll #.movitz:+movitz-fixnum-shift+ :eax)))) (<= bottom pointer top))) (defun stack-ref (pointer offset index type) From ffjeld at common-lisp.net Thu Apr 1 02:12:22 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 31 Mar 2004 21:12:22 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10081 Modified Files: integers.lisp Log Message: Changed logbitp somewhat. Date: Wed Mar 31 21:12:22 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.3 movitz/losp/muerte/integers.lisp:1.4 --- movitz/losp/muerte/integers.lisp:1.3 Thu Feb 26 08:46:36 2004 +++ movitz/losp/muerte/integers.lisp Wed Mar 31 21:12:22 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.3 2004/02/26 13:46:36 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.4 2004/04/01 02:12:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -846,10 +846,14 @@ (defun logbitp (index integer) (check-type integer fixnum) (with-inline-assembly (:returns :boolean-cf=1) - (:compile-form (:result-mode :eax) integer) - (:compile-form (:result-mode :untagged-fixnum-ecx) index) + (:compile-two-forms (:eax :ebx) index integer) + (:testl #x80000003 :eax) + (:jnz '(:sub-program () + (:int 66))) + (:movl :eax :ecx) + (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) (:addl #.movitz::+movitz-fixnum-shift+ :ecx) - (:btl :ecx :eax))) + (:btl :ecx :ebx))) (define-compiler-macro logbitp (&whole form index integer &environment env) (if (not (movitz:movitz-constantp index env)) From ffjeld at common-lisp.net Thu Apr 1 02:13:33 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 31 Mar 2004 21:13:33 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv14478 Modified Files: memref.lisp Log Message: Some tuning of memref. Date: Wed Mar 31 21:13:30 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.8 movitz/losp/muerte/memref.lisp:1.9 --- movitz/losp/muerte/memref.lisp:1.8 Wed Mar 31 16:35:27 2004 +++ movitz/losp/muerte/memref.lisp Wed Mar 31 21:13:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.8 2004/03/31 21:35:27 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.9 2004/04/01 02:13:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -65,8 +65,7 @@ (:movzxb (:eax ,(offset-by 1)) :ecx))) ((eq 0 offset) `(with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:eax :ecx) ,object ,index) - (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object ,index) (:movzxb (:eax :ecx ,(offset-by 1)) :ecx))) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) @@ -156,15 +155,11 @@ ((and (eq 0 offset) (eq 0 index)) `(with-inline-assembly (:returns :untagged-fixnum-ecx) (:compile-form (:result-mode :eax) ,object) - (:movl (:eax ,(offset-by 4)) :ecx) - (:cmpl ,movitz::+movitz-most-positive-fixnum+ :ecx) - (:jg '(:sub-program () (:int 4))))) + (:movl (:eax ,(offset-by 4)) :ecx))) ((eq 0 offset) `(with-inline-assembly (:returns :untagged-fixnum-ecx) (:compile-two-forms (:eax :ecx) ,object ,index) - (:movl (:eax :ecx ,(offset-by 4)) :ecx) - (:cmpl ,movitz::+movitz-most-positive-fixnum+ :ecx) - (:jg '(:sub-program () (:int 4))))) + (:movl (:eax :ecx ,(offset-by 4)) :ecx))) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) (with-inline-assembly (:returns :untagged-fixnum-ecx) @@ -269,8 +264,7 @@ ((and (movitz:movitz-constantp offset env) (movitz:movitz-constantp index env)) `(with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:ecx :ebx) ,value ,object) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,value ,object) (:movl :ecx (:ebx ,(+ (movitz:movitz-eval offset env) (* 4 (movitz:movitz-eval index env))))))) ((and (movitz:movitz-constantp offset env) @@ -317,8 +311,7 @@ ((and (movitz:movitz-constantp offset env) (movitz:movitz-constantp index env)) `(with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-two-forms (:ecx :ebx) ,value ,object) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,value ,object) (:movw :cx (:ebx ,(+ (movitz:movitz-eval offset env) (* 2 (movitz:movitz-eval index env))))))) ((and (movitz:movitz-constantp offset env) From ffjeld at common-lisp.net Thu Apr 1 02:15:22 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 31 Mar 2004 21:15:22 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/textmode.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv4971 Modified Files: textmode.lisp Log Message: Some minor code tuneups. Date: Wed Mar 31 21:15:22 2004 Author: ffjeld Index: movitz/losp/x86-pc/textmode.lisp diff -u movitz/losp/x86-pc/textmode.lisp:1.3 movitz/losp/x86-pc/textmode.lisp:1.4 --- movitz/losp/x86-pc/textmode.lisp:1.3 Mon Jan 19 06:23:52 2004 +++ movitz/losp/x86-pc/textmode.lisp Wed Mar 31 21:15:21 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 15:38:56 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: textmode.lisp,v 1.3 2004/01/19 11:23:52 ffjeld Exp $ +;;;; $Id: textmode.lisp,v 1.4 2004/04/01 02:15:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -45,7 +45,7 @@ (defun (setf cursor-row) (value &optional device) (declare (ignore device)) (setf *cursor-y* value) - (move-vga-cursor *cursor-x* *cursor-y*) + (move-vga-cursor *cursor-x* value) value) (defun cursor-column (&optional device) @@ -55,7 +55,7 @@ (defun (setf cursor-column) (value &optional device) (declare (ignore device)) (setf *cursor-x* value) - (move-vga-cursor *cursor-x* *cursor-y*) + (move-vga-cursor value *cursor-y*) value) (defun textmode-write-char (c) @@ -80,9 +80,9 @@ (cond ((= *screen-height* *cursor-y*) (textmode-scroll-down) - (move-vga-cursor *cursor-x* *cursor-y*)) + (move-vga-cursor 0 *cursor-y*)) (t (incf *cursor-y*) - (move-vga-cursor *cursor-x* *cursor-y*)))) + (move-vga-cursor 0 *cursor-y*)))) (#\backspace (if (/= 0 *cursor-x*) (decf *cursor-x*) @@ -92,18 +92,20 @@ (move-vga-cursor *cursor-x* *cursor-y*)) (#\return (setf *cursor-x* 0) - (move-vga-cursor *cursor-x* *cursor-y*)) + (move-vga-cursor 0 *cursor-y*)) (#\tab (textmode-write-char #\space) (do () ((zerop (rem *cursor-x* 8))) (textmode-write-char #\space))) - (t (when (>= *cursor-x* *screen-width*) - (textmode-write-char #\newline)) - (let ((index (+ *cursor-x* (* *cursor-y* *screen-stride*)))) - (setf (memref-int *screen* 0 index :unsigned-byte16 t) - (logior #x0700 (char-code c))) - (incf *cursor-x*) - (move-vga-cursor *cursor-x* *cursor-y*)))))) + (t (let ((x *cursor-x*) + (y *cursor-y*)) + (when (>= x *screen-width*) + (textmode-write-char #\newline) + (setf x *cursor-x* y *cursor-y*)) + (let ((index (+ x (* y *screen-stride*)))) + (setf (memref-int *screen* 0 index :unsigned-byte16 t) + (logior #x0700 (char-code c))) + (move-vga-cursor (setf *cursor-x* (1+ x)) y))))))) nil) (defun textmode-scroll-down () @@ -128,7 +130,6 @@ (:subl 1 :ecx) (:jnz 'clear-loop))) - (defun textmode-clear-line (from-column line) (let ((dest (+ *screen* (* line 80 2) (* from-column 2)))) (dotimes (i (- 80 from-column)) From ffjeld at common-lisp.net Thu Apr 1 16:07:37 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 01 Apr 2004 11:07:37 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/eval.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2560 Modified Files: eval.lisp Log Message: Added a mock compile function. Date: Thu Apr 1 11:07:37 2004 Author: ffjeld Index: movitz/losp/muerte/eval.lisp diff -u movitz/losp/muerte/eval.lisp:1.3 movitz/losp/muerte/eval.lisp:1.4 --- movitz/losp/muerte/eval.lisp:1.3 Sun Mar 28 08:23:57 2004 +++ movitz/losp/muerte/eval.lisp Thu Apr 1 11:07:37 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.3 2004/03/28 13:23:57 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.4 2004/04/01 16:07:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -388,3 +388,13 @@ (apply (lookup-setf-function (caar p)) (eval-form value-form env) place-subvalues))))))) + +(defun compile (name &optional definition) + "=> function, warnings-p, failure-p" + (let ((function (eval (or definition (symbol-function name))))) + (check-type function function) + (warn ";; There is no real compiler here.") + (values (if (not name) + function + (setf (symbol-function name) function)) + t nil))) \ No newline at end of file From ffjeld at common-lisp.net Thu Apr 1 17:26:04 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 01 Apr 2004 12:26:04 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler-types.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv17689 Modified Files: compiler-types.lisp Log Message: Don't forget the character type. Date: Thu Apr 1 12:26:04 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.8 movitz/compiler-types.lisp:1.9 --- movitz/compiler-types.lisp:1.8 Sat Feb 14 17:47:25 2004 +++ movitz/compiler-types.lisp Thu Apr 1 12:26:04 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.8 2004/02/14 22:47:25 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.9 2004/04/01 17:26:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -423,7 +423,7 @@ (cond ((atom type-specifier) (case type-specifier - ((t nil cons symbol keyword function array vector integer hash-table) + ((t nil cons symbol keyword function array vector integer hash-table character) (type-values type-specifier)) (null (type-values () :members '(nil))) From ffjeld at common-lisp.net Thu Apr 1 17:27:04 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 01 Apr 2004 12:27:04 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv20224 Modified Files: compiler.lisp Log Message: More stuff about using ECX only as a scratch register (i.e. it can't be used to hold pointer values that might be moved by GC). Date: Thu Apr 1 12:27:03 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.40 movitz/compiler.lisp:1.41 --- movitz/compiler.lisp:1.40 Wed Mar 31 21:09:26 2004 +++ movitz/compiler.lisp Thu Apr 1 12:27: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.40 2004/04/01 02:09:26 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.41 2004/04/01 17:27:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2433,7 +2433,7 @@ pos))))) (defun compute-free-registers (pc distance funobj frame-map - &key (free-registers '(:eax :ebx :ecx :edx))) + &key (free-registers '(:ecx :eax :ebx :edx))) "Return set of free register, and whether there may be more registers free later, with a more specified frame-map." (loop with free-so-far = free-registers @@ -2518,22 +2518,35 @@ (distance (position load-instruction (cdr init-pc)))) (multiple-value-bind (free-registers more-later-p) (and distance (compute-free-registers (cdr init-pc) distance funobj frame-map)) - (if (and (member :ecx free-registers) + (let ((free-registers-no-ecx (remove :ecx free-registers))) + (cond + ((member binding-destination free-registers-no-ecx) + binding-destination) + ((and (not (typep binding '(or fixed-required-function-argument + register-required-function-argument))) + (member binding-destination free-registers)) + binding-destination) + ((member init-with-register free-registers) + init-with-register) + ((and (member :ecx free-registers) (not (typep binding 'function-argument)) (or (eq :untagged-fixnum-ecx binding-destination) (eq :untagged-fixnum-ecx init-with-register))) - :untagged-fixnum-ecx - (let ((free-registers (remove :ecx free-registers))) - (cond - ((member binding-destination free-registers) - binding-destination) - ((member init-with-register free-registers) - init-with-register) - ((not (null free-registers)) - (first free-registers)) - (more-later-p - (values nil :not-now)) - (t (values nil :never))))))))) + :untagged-fixnum-ecx) + ((and (binding-store-type binding) + (member :ecx free-registers) + (not (typep binding '(or fixed-required-function-argument + register-required-function-argument))) + (multiple-value-call #'encoded-subtypep + (values-list (binding-store-type binding)) + (type-specifier-encode '(or integer character)))) + (warn "for ecX: ~S" binding) + :ecx) + ((not (null free-registers-no-ecx)) + (first free-registers-no-ecx)) + (more-later-p + (values nil :not-now)) + (t (values nil :never)))))))) (t (values nil :never))))) (defun discover-variables (code function-env) @@ -3050,7 +3063,7 @@ ((:eax :single-value) nil) (:untagged-fixnum-ecx `((:movl :eax :ecx) - (:sarl ,movitz:+movitz-fixnum-factor+ :ecx))))) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx))))) ((:ebx :ecx :edx) (assert (not indirect-p)) (unless (eq result-mode lexb-location) @@ -3059,7 +3072,7 @@ ((:ebx :ecx :edx :esi) `((:movl ,lexb-location ,result-mode))) (:untagged-fixnum-ecx `((:movl ,lexb-location :ecx) - (:sarl ,movitz:+movitz-fixnum-factor+ :ecx)))))) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx)))))) (:argument-stack (assert (<= 2 (function-argument-argnum lexb)) () "lexical :argument-stack argnum can't be ~A." (function-argument-argnum lexb)) @@ -3132,8 +3145,6 @@ `((:movl (:ebp ,(stack-frame-offset binding-location)) :eax) (:pushl (:eax -1))) (ecase binding-location -;;; (:eax '((:pushl :eax))) -;;; (:ebx '((:pushl :ebx))) (:argument-stack (assert (<= 2 (function-argument-argnum binding)) () ":load-lexical argnum can't be ~A." (function-argument-argnum binding)) @@ -3150,8 +3161,8 @@ (if (integerp binding-location) `((:pushl (:ebp ,(stack-frame-offset binding-location)))) (ecase binding-location - (:eax '((:pushl :eax))) - (:ebx '((:pushl :ebx))) + ((:eax :ebx :ecx :edx) + `((:pushl ,binding-location))) (:argument-stack (assert (<= 2 (function-argument-argnum binding)) () ":load-lexical argnum can't be ~A." (function-argument-argnum binding)) @@ -3254,7 +3265,7 @@ (if (integerp location) `((:movl ,source (:ebp ,(stack-frame-offset location)))) (ecase location - ((:eax :ebx :edx) + ((:eax :ebx :ecx :edx) (unless (eq source location) `((:movl ,source ,location)))) (:argument-stack From ffjeld at common-lisp.net Thu Apr 1 17:29:44 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 01 Apr 2004 12:29:44 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ip4.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv17687 Modified Files: ip4.lisp Log Message: Minor edits. Date: Thu Apr 1 12:29:44 2004 Author: ffjeld Index: movitz/losp/lib/net/ip4.lisp diff -u movitz/losp/lib/net/ip4.lisp:1.5 movitz/losp/lib/net/ip4.lisp:1.6 --- movitz/losp/lib/net/ip4.lisp:1.5 Thu Feb 26 06:26:24 2004 +++ movitz/losp/lib/net/ip4.lisp Thu Apr 1 12:29:44 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 30 13:52:57 2003 ;;;; -;;;; $Id: ip4.lisp,v 1.5 2004/02/26 11:26:24 ffjeld Exp $ +;;;; $Id: ip4.lisp,v 1.6 2004/04/01 17:29:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -91,8 +91,12 @@ (loop for x from y below (min (length packet) (+ y 16)) as c = (code-char (aref packet x)) do (write-char (if (alphanumericp c) c #\.))))) - ((mismatch packet (address stack) :start1 (+ start +ip-header-destination+) :end1 (+ start +ip-header-destination+ 4)) - #+ignore (warn "IPv4 Packet from ~@/ip4:pprint-ip4/ not for me, but for ~:/ip4:pprint-ip4/." packet packet)) + ((mismatch packet (address stack) + :start1 (+ start +ip-header-destination+) + :end1 (+ start +ip-header-destination+ 4)) + #+ignore + (warn "IPv4 Packet from ~@/ip4:pprint-ip4/ not for me, but for ~:/ip4:pprint-ip4/." + packet packet)) (t (named-integer-case ip-protocol (ip-protocol packet start) (icmp (icmp-input stack packet start (+ start header-size))) @@ -244,7 +248,7 @@ (+ (ldb (byte 16 0) new-checksum) (ash new-checksum -16)))) (transmit (interface stack) packet) - (write-char #\.))))) + #+ignore (write-char #\.))))) ;;;; UDP From ffjeld at common-lisp.net Thu Apr 1 20:25:08 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 01 Apr 2004 15:25:08 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/eval.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20384 Modified Files: eval.lisp Log Message: Added defvar as a special-operator. ..Why not? Date: Thu Apr 1 15:25:07 2004 Author: ffjeld Index: movitz/losp/muerte/eval.lisp diff -u movitz/losp/muerte/eval.lisp:1.4 movitz/losp/muerte/eval.lisp:1.5 --- movitz/losp/muerte/eval.lisp:1.4 Thu Apr 1 11:07:37 2004 +++ movitz/losp/muerte/eval.lisp Thu Apr 1 15:25:07 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.4 2004/04/01 16:07:37 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.5 2004/04/01 20:25:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -54,6 +54,19 @@ (or (and binding (cdr binding)) (symbol-value form))))) +;;; block let* return-from +;;; catch load-time-value setq +;;; eval-when locally symbol-macrolet +;;; flet macrolet tagbody +;;; function multiple-value-call the +;;; go multiple-value-prog1 throw +;;; if progn unwind-protect +;;; labels progv +;;; let quote +;;; +;;;Figure 3-2. Common Lisp Special Operators + + (defun eval-cons (form env) "3.1.2.1.2 Conses as Forms" (case (car form) @@ -69,6 +82,7 @@ (go (eval-go form env)) (setq (eval-setq form env)) (setf (eval-setf form env)) + ((defvar) (eval-defvar form env)) (let (eval-let (cadr form) (cddr form) env)) (time (eval-time (cadr form) env)) ((defun) (eval-defun (cadr form) (caddr form) (cdddr form) env)) @@ -389,6 +403,15 @@ (eval-form value-form env) place-subvalues))))))) +(defun eval-defvar (form env) + (let ((name (second form))) + (check-type name symbol "variable name") + (setf (symbol-special-variable-p name) t) + (when (and (cddr form) (not (boundp name))) + (setf (symbol-value name) + (eval-form (third form) env))) + name)) + (defun compile (name &optional definition) "=> function, warnings-p, failure-p" (let ((function (eval (or definition (symbol-function name))))) @@ -397,4 +420,5 @@ (values (if (not name) function (setf (symbol-function name) function)) - t nil))) \ No newline at end of file + t nil))) + From ffjeld at common-lisp.net Tue Apr 6 10:37:53 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 06:37:53 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv8009 Modified Files: interrupt.lisp Log Message: Added functions cli and sti, and minor edits. Date: Tue Apr 6 06:37:52 2004 Author: ffjeld Index: movitz/losp/x86-pc/interrupt.lisp diff -u movitz/losp/x86-pc/interrupt.lisp:1.6 movitz/losp/x86-pc/interrupt.lisp:1.7 --- movitz/losp/x86-pc/interrupt.lisp:1.6 Sun Mar 28 08:35:45 2004 +++ movitz/losp/x86-pc/interrupt.lisp Tue Apr 6 06:37:52 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri May 4 18:08:50 2001 ;;;; -;;;; $Id: interrupt.lisp,v 1.6 2004/03/28 13:35:45 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.7 2004/04/06 10:37:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -53,7 +53,7 @@ (setf (memref frame (* 4 (int-frame-index reg)) 0 type) x)) (define-primitive-function muerte::default-interrupt-trampoline () - "Default interrupt handler." + "Default first-stage interrupt handler." #.(cl:list* 'with-inline-assembly '(:returns :nothing) (cl:loop :for i :from 0 :to movitz::+idt-size+ :append (cl:if (cl:member i '(8 10 11 12 13 14 17)) @@ -80,7 +80,7 @@ ;; 8: ebp ;; 4: esi ;; 0: edi - + (:pushl (:esp 48)) ; EFLAGS (:pushl :cs) ; push CS (:call (:pc+ 0)) ; push EIP. @@ -241,6 +241,8 @@ ;; (print-dynamic-context); what's this? (throw :debugger nil)) (112 + (setf (%run-time-context-slot 'nursery-space) + (memref (%run-time-context-slot 'nursery-space) -6 3 :lisp)) (error "Out of memory. Please take out the garbage.")) (t (funcall (if (< 16 number 50) #'warn #'error) "Exception occurred: ~D, EIP: ~@Z, EAX: ~@Z, ECX: ~@Z, ESI: ~@Z" @@ -267,6 +269,13 @@ (setf (pic8259-irq-mask) #xfffe) (with-inline-assembly (:returns :nothing) (:sti))) +(defun cli () + (with-inline-assembly (:returns :nothing) + (:cli))) + +(defun sti () + (with-inline-assembly (:returns :nothing) + (:sti))) (defun interrupt-handler (n) (let ((vector (load-global-constant interrupt-handlers))) From ffjeld at common-lisp.net Tue Apr 6 13:35:41 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 09:35:41 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler-types.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv17668 Modified Files: compiler-types.lisp Log Message: A hack to teach the compiler that fixnum == integer (for now). Date: Tue Apr 6 09:35:41 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.9 movitz/compiler-types.lisp:1.10 --- movitz/compiler-types.lisp:1.9 Thu Apr 1 12:26:04 2004 +++ movitz/compiler-types.lisp Tue Apr 6 09:35:41 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.9 2004/04/01 17:26:04 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.10 2004/04/06 13:35:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -423,6 +423,8 @@ (cond ((atom type-specifier) (case type-specifier + (fixnum + (type-values 'integer)) ((t nil cons symbol keyword function array vector integer hash-table character) (type-values type-specifier)) (null From ffjeld at common-lisp.net Tue Apr 6 13:36:42 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 09:36:42 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv14476 Modified Files: los0.lisp Log Message: Safeifyed the los0-debugger a bit. Date: Tue Apr 6 09:36:42 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.9 movitz/losp/los0.lisp:1.10 --- movitz/losp/los0.lisp:1.9 Wed Mar 31 11:37:13 2004 +++ movitz/losp/los0.lisp Tue Apr 6 09:36:42 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.9 2004/03/31 16:37:13 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.10 2004/04/06 13:36:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -821,7 +821,8 @@ (*repl-prompt-context* #\d) (*repl-readline-context* (or *repl-readline-context* (make-readline-context :history-size 16)))) - (invoke-toplevel-command :error) + (let ((*print-safely* t)) + (invoke-toplevel-command :error)) (loop (with-simple-restart (abort "Abort to command level ~D." (1+ *repl-level*)) (read-eval-print))))) @@ -838,7 +839,7 @@ ;;; (loop for i from #x40600 below #x80000 ;;; do (setf (memref i 0 0 :unsigned-byte32) #xababe13)) - + (install-los0-consing) (let ((*repl-readline-context* (make-readline-context :history-size 16)) From ffjeld at common-lisp.net Tue Apr 6 13:38:21 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 09:38:21 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv22591 Modified Files: los0-gc.lisp Log Message: Minor edits (?), need the muerte package qualifier here and there. Date: Tue Apr 6 09:38:21 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.2 movitz/losp/los0-gc.lisp:1.3 --- movitz/losp/los0-gc.lisp:1.2 Wed Mar 31 11:36:29 2004 +++ movitz/losp/los0-gc.lisp Tue Apr 6 09:38:21 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.2 2004/03/31 16:36:29 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.3 2004/04/06 13:38:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -110,7 +110,7 @@ (allocate-duo-space)) (let ((conser (symbol-value 'new-fast-cons))) (check-type conser vector) - (setf (%run-time-context-slot 'fast-cons) + (setf (%run-time-context-slot 'muerte::fast-cons) conser)) (let ((old-malloc (symbol-function 'muerte:malloc-clumps))) (setf (symbol-function 'muerte:malloc-clumps) @@ -120,9 +120,9 @@ (values)) (defun install-old-consing () - (let ((conser (symbol-value 'fast-cons))) + (let ((conser (symbol-value 'muerte::fast-cons))) (check-type conser vector) - (setf (%run-time-context-slot 'fast-cons) + (setf (%run-time-context-slot 'muerte::fast-cons) conser)) (let ((old-malloc (symbol-function 'muerte:malloc-clumps))) (setf (symbol-function 'muerte:malloc-clumps) From ffjeld at common-lisp.net Tue Apr 6 13:39:47 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 09:39:47 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24165 Modified Files: basic-macros.lisp Log Message: Improved parsing in the do and do* compiler-macro, which puked at some quite legal forms. Date: Tue Apr 6 09:39:47 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.5 movitz/losp/muerte/basic-macros.lisp:1.6 --- movitz/losp/muerte/basic-macros.lisp:1.5 Wed Mar 24 19:55:12 2004 +++ movitz/losp/muerte/basic-macros.lisp Tue Apr 6 09:39:47 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.5 2004/03/25 00:55:12 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.6 2004/04/06 13:39:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -189,7 +189,12 @@ (define-compiler-macro do (var-specs (end-test-form &rest result-forms) &body declarations-and-body) (flet ((var-spec-let-spec (var-spec) - (if (symbolp var-spec) var-spec (subseq var-spec 0 2))) + (cond + ((symbolp var-spec) + var-spec) + ((cddr var-spec) + (subseq var-spec 0 2)) + (t var-spec))) (var-spec-var (var-spec) (if (symbolp var-spec) var-spec (car var-spec))) (var-spec-step-form (var-spec) @@ -220,7 +225,12 @@ (defmacro do* (var-specs (end-test-form &rest result-forms) &body declarations-and-body) (flet ((var-spec-let-spec (var-spec) - (if (symbolp var-spec) var-spec (subseq var-spec 0 2))) + (cond + ((symbolp var-spec) + var-spec) + ((cddr var-spec) + (subseq var-spec 0 2)) + (t var-spec))) (var-spec-var (var-spec) (if (symbolp var-spec) var-spec (car var-spec))) (var-spec-step-form (var-spec) From ffjeld at common-lisp.net Tue Apr 6 14:05:18 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 10:05:18 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6786 Modified Files: conditions.lisp Log Message: Moved condition-related macros from conditions.lisp to more-macros.lisp. Date: Tue Apr 6 10:05:18 2004 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.3 movitz/losp/muerte/conditions.lisp:1.4 --- movitz/losp/muerte/conditions.lisp:1.3 Fri Mar 12 06:47:41 2004 +++ movitz/losp/muerte/conditions.lisp Tue Apr 6 10:05:18 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.3 2004/03/12 11:47:41 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.4 2004/04/06 14:05:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -19,7 +19,6 @@ (in-package muerte) -(defvar *active-condition-handlers* nil) (defparameter *break-on-signals* nil) (defparameter *debugger-function* nil) @@ -134,81 +133,6 @@ (declare (dynamic-extent slot-initializations)) (apply 'make-instance type slot-initializations)) -(defmacro handler-bind (bindings &body forms) - (if (null bindings) - `(progn , at forms) - (labels ((make-handler (binding) - (destructuring-bind (type handler) - binding - (cond - #+ignore - ((and (listp handler) - (eq 'lambda (first handler)) - (= 1 (length (second handler)))) - `(cons t (lambda (x) - (when (typep x ',type) - (let ((,(first (second handler)) x)) - ,@(cddr handler))) - nil))) - #+ignore - ((and (listp handler) - (eq 'function (first handler)) - (listp (second handler)) - (eq 'lambda (first (second handler))) - (= 1 (length (second (second handler))))) - (make-handler (list type (second handler)))) - (t `(cons ',type ,handler)))))) - `(let ((*active-condition-handlers* - (cons (list ,@(mapcar #'make-handler #+ignore (lambda (binding) - `(cons ',(first binding) - ,(second binding))) - bindings)) - *active-condition-handlers*))) - , at forms)))) - -(defmacro handler-case (expression &rest clauses) - (multiple-value-bind (normal-clauses no-error-clauses) - (loop for clause in clauses - if (eq :no-error (car clause)) - collect clause into no-error-clauses - else collect clause into normal-clauses - finally (return (values normal-clauses no-error-clauses))) - (case (length no-error-clauses) - (0 (let ((block-name (gensym "handler-case-block-")) - (var-name (gensym "handler-case-var-")) - (temp-name (gensym "handler-case-temp-var-")) - (specs (mapcar (lambda (clause) - (list clause (gensym "handler-case-clause-tag-"))) - normal-clauses))) - `(block ,block-name - (let (,var-name) - (tagbody - (handler-bind ,(mapcar (lambda (clause-spec) - (let* ((clause (first clause-spec)) - (go-tag (second clause-spec)) - (typespec (first clause))) - `(,typespec (lambda (,temp-name) - (setq ,var-name ,temp-name) - (go ,go-tag))))) - specs) - (return-from ,block-name ,expression)) - ,@(mapcan (lambda (clause-spec) - (let* ((clause (first clause-spec)) - (go-tag (second clause-spec)) - (var (first (second clause))) - (body (cddr clause))) - (if (not var) - `(,go-tag (return-from ,block-name - (let () , at body))) - `(,go-tag (return-from ,block-name - (let ((,var ,var-name)) - , at body)))))) - specs)))))) - (t (error "Too many no-error clauses."))))) - -(defmacro ignore-errors (&body body) - `(handler-case (progn , at body) - (error (c) (values nil c)))) (defun warn (datum &rest arguments) (declare (dynamic-extent arguments)) From ffjeld at common-lisp.net Tue Apr 6 14:05:23 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 10:05:23 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20256 Modified Files: more-macros.lisp Log Message: Moved condition-related macros from conditions.lisp to more-macros.lisp. Date: Tue Apr 6 10:05:23 2004 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.4 movitz/losp/muerte/more-macros.lisp:1.5 --- movitz/losp/muerte/more-macros.lisp:1.4 Thu Mar 25 20:50:32 2004 +++ movitz/losp/muerte/more-macros.lisp Tue Apr 6 10:05:23 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.4 2004/03/26 01:50:32 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.5 2004/04/06 14:05:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -216,3 +216,79 @@ + +(defmacro handler-bind (bindings &body forms) + (if (null bindings) + `(progn , at forms) + (labels ((make-handler (binding) + (destructuring-bind (type handler) + binding + (cond + #+ignore + ((and (listp handler) + (eq 'lambda (first handler)) + (= 1 (length (second handler)))) + `(cons t (lambda (x) + (when (typep x ',type) + (let ((,(first (second handler)) x)) + ,@(cddr handler))) + nil))) + #+ignore + ((and (listp handler) + (eq 'function (first handler)) + (listp (second handler)) + (eq 'lambda (first (second handler))) + (= 1 (length (second (second handler))))) + (make-handler (list type (second handler)))) + (t `(cons ',type ,handler)))))) + `(let ((*active-condition-handlers* + (cons (list ,@(mapcar #'make-handler #+ignore (lambda (binding) + `(cons ',(first binding) + ,(second binding))) + bindings)) + *active-condition-handlers*))) + , at forms)))) + +(defmacro handler-case (expression &rest clauses) + (multiple-value-bind (normal-clauses no-error-clauses) + (loop for clause in clauses + if (eq :no-error (car clause)) + collect clause into no-error-clauses + else collect clause into normal-clauses + finally (return (values normal-clauses no-error-clauses))) + (case (length no-error-clauses) + (0 (let ((block-name (gensym "handler-case-block-")) + (var-name (gensym "handler-case-var-")) + (temp-name (gensym "handler-case-temp-var-")) + (specs (mapcar (lambda (clause) + (list clause (gensym "handler-case-clause-tag-"))) + normal-clauses))) + `(block ,block-name + (let (,var-name) + (tagbody + (handler-bind ,(mapcar (lambda (clause-spec) + (let* ((clause (first clause-spec)) + (go-tag (second clause-spec)) + (typespec (first clause))) + `(,typespec (lambda (,temp-name) + (setq ,var-name ,temp-name) + (go ,go-tag))))) + specs) + (return-from ,block-name ,expression)) + ,@(mapcan (lambda (clause-spec) + (let* ((clause (first clause-spec)) + (go-tag (second clause-spec)) + (var (first (second clause))) + (body (cddr clause))) + (if (not var) + `(,go-tag (return-from ,block-name + (let () , at body))) + `(,go-tag (return-from ,block-name + (let ((,var ,var-name)) + , at body)))))) + specs)))))) + (t (error "Too many no-error clauses."))))) + +(defmacro ignore-errors (&body body) + `(handler-case (progn , at body) + (error (c) (values nil c)))) From ffjeld at common-lisp.net Tue Apr 6 14:25:44 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 10:25:44 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10917 Modified Files: memref.lisp Log Message: Various improvements to memref and (setf memref). Date: Tue Apr 6 10:25:44 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.9 movitz/losp/muerte/memref.lisp:1.10 --- movitz/losp/muerte/memref.lisp:1.9 Wed Mar 31 21:13:27 2004 +++ movitz/losp/muerte/memref.lisp Tue Apr 6 10:25:44 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.9 2004/04/01 02:13:27 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.10 2004/04/06 14:25:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -21,30 +21,40 @@ (define-compiler-macro memref (&whole form object offset index type &environment env) (if (not (movitz:movitz-constantp type env)) form - (labels ((extract-constant-delta (form) - "Try to extract at compile-time an integer offset from form." - (cond - ((movitz:movitz-constantp form env) - (let ((x (movitz:movitz-eval form env))) - (check-type x integer) - (values x 0))) - ((not (consp form)) - (values 0 form)) - (t (case (car form) - (1+ (values 1 (second form))) - (1- (values -1 (second form))) - (+ (case (length form) - (1 (values 0 0)) - (2 (values 0 (second form))) - (t (loop with x = 0 and f = nil for sub-form in (cdr form) - as sub-value = (when (movitz:movitz-constantp sub-form env) - (movitz:movitz-eval sub-form env)) - do (if (integerp sub-value) - (incf x sub-value) - (push sub-form f)) - finally (return (values x (cons '+ (nreverse f)))))))) - (t #+ignore (warn "extract from: ~S" form) - (values 0 form))))))) + (labels ((sub-extract-constant-delta (form) + "Try to extract at compile-time an integer offset from form." + (cond + ((movitz:movitz-constantp form env) + (let ((x (movitz:movitz-eval form env))) + (check-type x integer) + (values x 0))) + ((not (consp form)) + (values 0 form)) + (t (case (car form) + (1+ (values 1 (second form))) + (1- (values -1 (second form))) + (+ (case (length form) + (1 (values 0 0)) + (2 (values 0 (second form))) + (t (loop with x = 0 and f = nil for sub-form in (cdr form) + as sub-value = (when (movitz:movitz-constantp sub-form env) + (movitz:movitz-eval sub-form env)) + do (if (integerp sub-value) + (incf x sub-value) + (push sub-form f)) + finally (return (values x (cons '+ (nreverse f)))))))) + (t #+ignore (warn "extract from: ~S" form) + (values 0 form)))))) + (extract-constant-delta (form) + "Try to extract at compile-time an integer offset from form, repeatedly." + (multiple-value-bind (constant-term variable-term) + (sub-extract-constant-delta form) + (if (= 0 constant-term) + (values 0 variable-term) + (multiple-value-bind (sub-constant-term sub-variable-term) + (extract-constant-delta variable-term) + (values (+ constant-term sub-constant-term) + sub-variable-term)))))) (multiple-value-bind (constant-index index) (extract-constant-delta index) (multiple-value-bind (constant-offset offset) @@ -189,7 +199,7 @@ `(let ((,object-var ,object)) (with-inline-assembly (:returns :eax) (:compile-two-forms (:ecx :ebx) ,offset ,index) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:load-lexical (:lexical-binding ,object-var) :eax) (:addl :ebx :ecx) (:movl (:eax :ecx ,(offset-by 4)) :eax))))))) @@ -259,7 +269,7 @@ (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ebx) ,object) (:movl ,value (:ebx ,(+ (movitz:movitz-eval offset env) - (* 2 (movitz:movitz-eval index env)))))) + (* 4 (movitz:movitz-eval index env)))))) ,value))) ((and (movitz:movitz-constantp offset env) (movitz:movitz-constantp index env)) @@ -321,7 +331,7 @@ `(progn (with-inline-assembly (:returns :nothing) (:compile-two-forms (:ecx :ebx) ,index ,object) - (:shrl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) (:movw ,value (:ebx :ecx ,(movitz:movitz-eval offset env)))) ,value))) ((movitz:movitz-constantp offset env) @@ -331,13 +341,13 @@ (with-inline-assembly (:returns :untagged-fixnum-eax) (:compile-two-forms (:ebx :ecx) ,object ,index) (:load-lexical (:lexical-binding ,value-var) :untagged-fixnum-eax) - (:shrl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) (:movw :ax (:ebx :ecx ,(movitz:movitz-eval offset env))))) `(let ((,value-var ,value)) (with-inline-assembly (:returns :nothing) (:compile-two-forms (:ebx :ecx) ,object ,index) (:load-lexical (:lexical-binding ,value-var) :eax) - (:shrl ,(1- movitz:+movitz-fixnum-shift+) :ecx) + (:sarl ,(1- movitz:+movitz-fixnum-shift+) :ecx) (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax) (:movb :ah (:ebx :ecx ,(movitz:movitz-eval offset env))) (:andl #xff0000 :eax) @@ -397,7 +407,7 @@ `(progn (with-inline-assembly (:returns :untagged-fixnum-ecx) (:compile-two-forms (:eax :ecx) ,object ,index) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:movb ,value (:eax :ecx ,(movitz:movitz-eval offset env)))) value))) ((movitz:movitz-constantp offset env) @@ -406,7 +416,7 @@ (with-inline-assembly (:returns :nothing) (:compile-two-forms (:ebx :ecx) ,object ,index) (:load-lexical (:lexical-binding ,value-var) :eax) - (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) (:shll ,(- 8 movitz:+movitz-fixnum-shift+) :eax) ; value into :AH (:movb :ah (:ebx :ecx ,(movitz:movitz-eval offset env)))) ,value-var))) From ffjeld at common-lisp.net Tue Apr 6 14:29:33 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 10:29:33 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3168 Modified Files: print.lisp Log Message: Added support for *print-safely* in write. In this mode, try to print some opaque error message rather than signal an error condition. Date: Tue Apr 6 10:29:33 2004 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.4 movitz/losp/muerte/print.lisp:1.5 --- movitz/losp/muerte/print.lisp:1.4 Tue Mar 30 16:32:12 2004 +++ movitz/losp/muerte/print.lisp Tue Apr 6 10:29:33 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.4 2004/03/30 21:32:12 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.5 2004/04/06 14:29:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -33,6 +33,8 @@ (defvar *print-pretty* t) (defvar *print-circle* nil) +(defvar *print-safely* nil) + (defvar *standard-output* #'muerte.x86-pc::textmode-console) (defvar *standard-input* #'muerte.x86-pc::textmode-console) (defvar *debug-io* #'muerte.x86-pc::textmode-console) @@ -148,18 +150,24 @@ (write-char #\Newline stream) string) -(defun write (object &key stream case circle - (array *print-array*) (base *print-base*) - ((:escape *print-escape*) *print-escape*) - ((:gensym *print-gensym*) *print-gensym*) - (length *print-length*) - (level *print-level*) lines miser-width pprint-dispatch - (pretty *print-pretty*) (radix *print-radix*) - ((:readably *print-readably*) *print-readably*) - right-margin) - (declare (special *read-base* *package*) +(defun write (object &rest key-args + &key stream case circle safe-recursive-call + (array *print-array*) (base *print-base*) + ((:escape *print-escape*) *print-escape*) + ((:gensym *print-gensym*) *print-gensym*) + (length *print-length*) + (level *print-level*) lines miser-width pprint-dispatch + (pretty *print-pretty*) (radix *print-radix*) + ((:readably *print-readably*) *print-readably*) + right-margin) + (declare (dynamic-extent key-args) + (special *read-base* *package*) (ignore case circle pprint-dispatch miser-width right-margin lines)) (cond + ((and *print-safely* (not safe-recursive-call)) + (handler-case (apply #'write object :safe-recursive-call t key-args) + (t (condition) + (write-string "#" stream)))) ((and (not pretty) (not *never-use-print-object*)) (print-object object stream)) From ffjeld at common-lisp.net Tue Apr 6 14:30:48 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 10:30:48 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15010 Modified Files: symbols.lisp Log Message: Add writers (setf symbol-special-variable-p) and (setf symbol-constant-variable-p). Date: Tue Apr 6 10:30:48 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.6 movitz/losp/muerte/symbols.lisp:1.7 --- movitz/losp/muerte/symbols.lisp:1.6 Sun Mar 28 20:57:48 2004 +++ movitz/losp/muerte/symbols.lisp Tue Apr 6 10:30:48 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.6 2004/03/29 01:57:48 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.7 2004/04/06 14:30:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -193,8 +193,18 @@ (defun symbol-special-variable-p (symbol) (logbitp 0 (symbol-flags symbol))) +(defun (setf symbol-special-variable-p) (value symbol) + (setf (ldb (byte 1 0) (symbol-flags symbol)) + (if value 1 0)) + value) + (defun symbol-constant-variable-p (symbol) (logbitp 1 (symbol-flags symbol))) + +(defun (setf symbol-constant-variable-p) (value symbol) + (setf (ldb (byte 1 1) (symbol-flags symbol)) + (if value 1 0)) + value) (defvar *gensym-counter* 0) From ffjeld at common-lisp.net Tue Apr 6 14:31:09 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 10:31:09 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/variables.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29504 Modified Files: variables.lisp Log Message: Move variable *active-condition-handlers* here. Date: Tue Apr 6 10:31:09 2004 Author: ffjeld Index: movitz/losp/muerte/variables.lisp diff -u movitz/losp/muerte/variables.lisp:1.3 movitz/losp/muerte/variables.lisp:1.4 --- movitz/losp/muerte/variables.lisp:1.3 Wed Mar 24 18:42:49 2004 +++ movitz/losp/muerte/variables.lisp Tue Apr 6 10:31:09 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 5 21:53:34 2003 ;;;; -;;;; $Id: variables.lisp,v 1.3 2004/03/24 23:42:49 ffjeld Exp $ +;;;; $Id: variables.lisp,v 1.4 2004/04/06 14:31:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -35,6 +35,7 @@ (defvar +++ nil) (defparameter *debugger-hook* nil) +(defvar *active-condition-handlers* nil) (defvar internal-time-units-per-second) From ffjeld at common-lisp.net Tue Apr 6 14:32:00 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 10:32:00 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/segments.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv22563 Modified Files: segments.lisp Log Message: Re-write of sgdt and new function lgdt. Date: Tue Apr 6 10:32:00 2004 Author: ffjeld Index: movitz/losp/muerte/segments.lisp diff -u movitz/losp/muerte/segments.lisp:1.2 movitz/losp/muerte/segments.lisp:1.3 --- movitz/losp/muerte/segments.lisp:1.2 Mon Jan 19 06:23:47 2004 +++ movitz/losp/muerte/segments.lisp Tue Apr 6 10:32:00 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu May 8 14:25:06 2003 ;;;; -;;;; $Id: segments.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $ +;;;; $Id: segments.lisp,v 1.3 2004/04/06 14:32:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -51,20 +51,43 @@ value) (defun sgdt () - (without-gc - (with-inline-assembly (:returns :multiple-values) - (:pushl 0) - (:pushl 0) - (:leal (:esp 2) :ecx) - (:sgdt (:ecx)) - (:popl :ecx) - ;; (:andl #xffff :ecx) - (:shrl 16 :ecx) - (:leal ((:ecx #.movitz::+movitz-fixnum-factor+)) :ebx) - (:popl :ecx) - (:leal ((:ecx #.movitz::+movitz-fixnum-factor+)) :eax) - (:movl 2 :ecx) - (:stc)))) + "Return the location of the GDT, and the limit. +Error if the GDT location is not zero modulo 4." + (eval-when (:compile-toplevel) + (assert (= 4 movitz:+movitz-fixnum-factor+))) + (with-inline-assembly (:returns :multiple-values) + (:pushl #.movitz:+scan-skip-word+) + (:pushl 2) + (:pushl 0) + (:pushl 0) + (:leal (:esp 2) :ecx) + (:sgdt (:ecx)) + (:popl :ecx) + (:shrl 16 :ecx) + (:leal ((:ecx #.movitz::+movitz-fixnum-factor+)) :ebx) + (:popl :ecx) + (:testb 3 :cl) + (:jnz '(:sub-program () + (:compile-form (:result-mode :ignore) + (error "The GDT base is not 4-aligned.")))) + (:movl :ecx :eax) + (:movl 2 :ecx) + (:stc))) + +(defun lgdt (base-location limit) + "Set the GDT according to base-location and limit. +This is the setter corresponding to the sgdt getter." + (eval-when (:compile-toplevel) + (assert (= 4 movitz:+movitz-fixnum-factor+))) + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:eax :ebx) base-location limit) + (:pushl #.movitz:+scan-skip-word+) + (:pushl 2) + (:shll #.(cl:- 16 movitz:+movitz-fixnum-shift+) :ebx) + (:pushl :eax) + (:pushl :ebx) + (:leal (:esp 2) :ecx) + (:lgdt (:ecx)))) ;;; From ffjeld at common-lisp.net Tue Apr 6 14:33:11 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 10:33:11 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27745 Modified Files: scavenge.lisp Log Message: Minor edit. Date: Tue Apr 6 10:33:11 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.3 movitz/losp/muerte/scavenge.lisp:1.4 --- movitz/losp/muerte/scavenge.lisp:1.3 Wed Mar 31 11:36:34 2004 +++ movitz/losp/muerte/scavenge.lisp Tue Apr 6 10:33:10 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.3 2004/03/31 16:36:34 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.4 2004/04/06 14:33:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -95,8 +95,8 @@ (loop for nether-frame = start-stack-frame then frame and frame = (stack-frame-uplink start-stack-frame) then (stack-frame-uplink frame) while (plusp frame) - do (let ((funobj (stack-frame-funobj frame))) - (typecase funobj + do (let ((funobj (stack-frame-funobj frame t))) + (etypecase funobj (integer (error "Don't know how to scavenge across an interrupt frame.")) (function From ffjeld at common-lisp.net Tue Apr 6 14:34:46 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 10:34:46 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv23008 Modified Files: compiler.lisp Log Message: Default *compiler-auto-stack-checks-p* to t. Date: Tue Apr 6 10:34:46 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.41 movitz/compiler.lisp:1.42 --- movitz/compiler.lisp:1.41 Thu Apr 1 12:27:03 2004 +++ movitz/compiler.lisp Tue Apr 6 10:34:45 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.41 2004/04/01 17:27:03 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.42 2004/04/06 14:34:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,7 +28,7 @@ "Allow the compiler to emit CMOV instructions, making the code incompatible with pre-pentium CPUs.") -(defvar *compiler-auto-stack-checks-p* nil +(defvar *compiler-auto-stack-checks-p* t "Make every compiled function check upon entry that the stack-pointer is within bounds. Costs 3 code-bytes and a few cycles.") @@ -826,7 +826,8 @@ (let ((offset (cdr (assoc entry-label code-symtab)))) (setf (slot-value funobj slot-name) (cons offset funobj)) - (vector-push offset code-vector))) + (when (< offset #x100) + (vector-push offset code-vector)))) ((some (lambda (label) (assoc label code-symtab)) (mapcar #'car rest)) (vector-push 0 code-vector)))) @@ -4905,7 +4906,7 @@ (values (or (restore-by-pop :eax) `((:addl ,(* 4 stack-displacement) :esp))) :nothing)))))) - + (define-compiler compile-apply-symbol (&form form &funobj funobj &env env &result-mode result-mode) "3.1.2.1.2.3 Function Forms" From ffjeld at common-lisp.net Tue Apr 6 14:35:15 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 10:35:15 -0400 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv13184 Modified Files: packages.lisp Log Message: Added a few symbols. Date: Tue Apr 6 10:35:15 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.12 movitz/packages.lisp:1.13 --- movitz/packages.lisp:1.12 Wed Mar 31 11:32:22 2004 +++ movitz/packages.lisp Tue Apr 6 10:35:14 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.12 2004/03/31 16:32:22 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.13 2004/04/06 14:35:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1101,6 +1101,8 @@ print-word fixnump below print-unreadable-movitz-object + + #:*print-safely* stack-ref with-each-dynamic-context @@ -1287,6 +1289,7 @@ #:+movitz-fixnum-factor+ #:+movitz-fixnum-shift+ + #:+scan-skip-word+ #:constant0 #:movitz-object-browser-properties From ffjeld at common-lisp.net Tue Apr 6 14:35:36 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 10:35:36 -0400 Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29825 Modified Files: procfs-image.lisp Log Message: Minor edits. Date: Tue Apr 6 10:35:36 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.3 movitz/procfs-image.lisp:1.4 --- movitz/procfs-image.lisp:1.3 Thu Feb 5 09:19:36 2004 +++ movitz/procfs-image.lisp Tue Apr 6 10:35:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.3 2004/02/05 14:19:36 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.4 2004/04/06 14:35:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -270,12 +270,12 @@ #+allegro -(top-level:alias ("bochs" 0) (&rest forms) +(top-level:alias ("bochs" 0) (&optional form) (with-bochs-image () (with-simple-restart (continue "Exit this bochs session [pid=~D]" (image-pid *image*)) - (if forms - (let ((x (multiple-value-list (eval (cons 'progn forms))))) - (format t "~{~&~W~}" x) - (values-list x)) + (if form + (let ((x (eval form))) + (format t "~&~W" x) + x) (invoke-debugger "Established connection to Bochs [pid=~D]." (image-pid *image*)))))) From ffjeld at common-lisp.net Tue Apr 6 14:37:04 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 10:37:04 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/lib/repl.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv1346 Modified Files: repl.lisp Log Message: Use *print-safely* mode in read-eval-print. Date: Tue Apr 6 10:37:04 2004 Author: ffjeld Index: movitz/losp/lib/repl.lisp diff -u movitz/losp/lib/repl.lisp:1.9 movitz/losp/lib/repl.lisp:1.10 --- movitz/losp/lib/repl.lisp:1.9 Wed Mar 31 11:38:20 2004 +++ movitz/losp/lib/repl.lisp Tue Apr 6 10:37:04 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Mar 19 14:58:12 2003 ;;;; -;;;; $Id: repl.lisp,v 1.9 2004/03/31 16:38:20 ffjeld Exp $ +;;;; $Id: repl.lisp,v 1.10 2004/04/06 14:37:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -35,9 +35,10 @@ (defun read-eval-print (&optional (*repl-readline-context* *repl-readline-context*) (*repl-level* (1+ *repl-level*))) - (if (stringp *repl-prompter*) - (format t *repl-prompter* *repl-level* *package*) - (funcall *repl-prompter*)) + (let ((muerte:*print-safely* t)) + (if (stringp *repl-prompter*) + (format t *repl-prompter* *repl-level* *package*) + (funcall *repl-prompter*))) (handler-case (let ((previous-package *package*) (buffer-string (muerte.readline:contextual-readline *repl-readline-context*))) @@ -62,7 +63,8 @@ (warn "* was unbound!") (setf * nil)) (when printp - (apply #'format t *repl-print-format* results)) + (let ((muerte:*print-safely* t)) + (apply #'format t *repl-print-format* results))) (psetq +++ ++ ++ + + form) (psetq *** ** ** * * (car results)) (psetq /// // // / / (if *repl-consless* From ffjeld at common-lisp.net Tue Apr 6 14:42:11 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 10:42:11 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv9604 Modified Files: interrupt.lisp Log Message: Re-wrote default-interrupt-trampoline. This means the format of "interrupt-frames" is changed completely, thus also int-frame-index. Now, an "interrupt-frame" looks more like an ordinary stack-frame, only with some special rules about the GC-rootness of the slots immediately above (the stuff the CPU pushes on interrupts), and below (the interruptee registers we push) the frame. This is part of adding support for interrupt-frames to map-stack-words in scavenge.lisp. Date: Tue Apr 6 10:42:11 2004 Author: ffjeld Index: movitz/losp/x86-pc/interrupt.lisp diff -u movitz/losp/x86-pc/interrupt.lisp:1.7 movitz/losp/x86-pc/interrupt.lisp:1.8 --- movitz/losp/x86-pc/interrupt.lisp:1.7 Tue Apr 6 06:37:52 2004 +++ movitz/losp/x86-pc/interrupt.lisp Tue Apr 6 10:42:11 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri May 4 18:08:50 2001 ;;;; -;;;; $Id: interrupt.lisp,v 1.7 2004/04/06 10:37:52 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.8 2004/04/06 14:42:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -34,14 +34,17 @@ (movitz:movitz-eval name env)))) (if (not name) form - (position name '(:edi :esi :ebp :esp :ebx :edx :ecx :eax - :exception :error-code - :eip :cs :eflags))))) + (- 5 (position name + '(:eip :eflags nil :error-code :exception :ebp nil + :ecx :eax :edx :ebx :esi :edi) + #+ignore '(:edi :esi :ebp :esp :ebx :edx :ecx :eax + :exception :error-code + :eip :cs :eflags)))))) (defun int-frame-index (name) - (position name '(:edi :esi :ebp :esp :ebx :edx :ecx :eax - :exception :error-code - :eip :cs :eflags))) + (- 5 (position name + '(:eip :eflags nil :error-code :exception :ebp nil + :ecx :eax :edx :ebx :esi :edi)))) (define-compiler-macro int-frame-ref (&whole form frame reg type &optional (offset 0) &environment env) `(memref ,frame (+ (* 4 (int-frame-index ,reg)) ,offset) 0 ,type)) @@ -66,22 +69,34 @@ (with-inline-assembly (:returns :multiple-values) ok ;; Stack: - ;; 48: Calling EFLAGS - ;; 44: Calling CS - ;; 40: Calling EIP - ;; 36: error code - ;; 32: exception number - (:pushal) ; push interruptee's registers - ;; 28: eax - ;; 24: ecx - ;; 20: edx - ;; 16: ebx - ;; 12: esp - ;; 8: ebp - ;; 4: esi - ;; 0: edi + ;; 20: Interruptee EFLAGS (later EIP) + ;; 16: Interruptee CS (later EFLAGS) + ;; 12: Interruptee EIP + ;; 8: Error code + ;; 4: Exception number + ;; 0: EBP + (:pushl :ebp) + (:movl :esp :ebp) + (:pushl 0) ; 0 means default-interrupt-trampoline frame + (:pushl :ecx) ; -8 + (:pushl :eax) ; -12 + (:pushl :edx) ; -16 + (:pushl :ebx) ; -20 + (:pushl :esi) ; -24 + (:pushl :edi) ; -28 + + ;; rearrange stack for return + (:movl (:ebp 12) :eax) ; load return address + (:movl (:ebp 20) :ebx) ; load EFLAGS + (:movl :ebx (:ebp 16)) ; EFLAGS at next-to-bottom of stack + (:movl :eax (:ebp 20)) ; return address at bottom of stack + + (:xorl :eax :eax) ; Ensure safe value + (:xorl :edx :edx) ; Ensure safe value + + (:movl ':nil-value :edi) ; We want NIL! - (:pushl (:esp 48)) ; EFLAGS + (:pushl (:ebp 16)) ; EFLAGS (:pushl :cs) ; push CS (:call (:pc+ 0)) ; push EIP. ;; Now add a few bytes to the on-stack EIP so the iret goes to @@ -91,21 +106,12 @@ ;; *DEST* iret branches to here. ;; we're now in the context of the interruptee. - ;; rearrange stack for return - (:movl (:esp 40) :eax) ; load return address - (:movl (:esp 48) :ebx) ; load EFLAGS - (:movl :ebx (:esp 44)) ; EFLAGS at next-to-bottom of stack - - (:movl :eax (:esp 48)) ; return address at bottom of stack - - (:movl ':nil-value :edi) ; We want NIL! - - (:pushl :eax) ; fake stack-frame return address - (:pushl :ebp) ; set up fake stack-frame - (:movl :esp :ebp) ; (GIVES EBP OFFSET 8 RELATIVE TO NUMBERS ABOVE!!) - (:pushl :edi) ; A fake "funobj" for the fake stack-frame.. - ; ..the int-frame will be put here shortly. +;;; (:pushl :eax) ; fake stack-frame return address +;;; (:pushl :ebp) ; set up fake stack-frame +;;; (:movl :esp :ebp) ; (GIVES EBP OFFSET 8 RELATIVE TO NUMBERS ABOVE!!) +;;; (:pushl :edi) ; A fake "funobj" for the fake stack-frame.. +;;; ; ..the int-frame will be put here shortly. ;; Save/push thread-local values (:locally (:movl (:edi (:edi-offset num-values)) :ecx)) @@ -120,7 +126,7 @@ (:locally (:pushl (:edi (:edi-offset num-values)))) ;; call handler - (:movl (32 8 :ebp) :ebx) ; interrupt number into EBX + (:movl (:ebp 4) :ebx) ; interrupt number into EBX (:locally (:movl (:edi (:edi-offset interrupt-handlers)) :eax)) (:movl (:eax 2 (:ebx 4)) :eax) ; symbol at (aref EBX interrupt-handlers) into :esi (:leal (:eax -7) :ecx) @@ -128,9 +134,9 @@ (:jnz 'skip-interrupt-handler) ; if it's not a symbol, never mind. (:movl (:eax #.(movitz::slot-offset 'movitz::movitz-symbol 'movitz::function-value)) :esi) ; load new funobj from symbol into ESI - (:leal (8 :ebp) :ebx) ; pass INT-frame as arg1 - (:movl :ebx (:ebp -4)) ; put INT-frame as our fake stack-frame's funobj. - (:movl (32 8 :ebp) :eax) ; pass interrupt number as arg 0. + (:movl :ebp :ebx) ; pass INT-frame as arg1 + ;; (:movl :ebx (:ebp -4)) ; put INT-frame as our fake stack-frame's funobj. + (:movl (:ebp 4) :eax) ; pass interrupt number as arg 0. (:shll #.movitz::+movitz-fixnum-shift+ :eax) (:call (:esi #.(movitz::slot-offset 'movitz::movitz-funobj 'movitz::code-vector%2op))) @@ -145,11 +151,20 @@ (:subl 1 :ecx) (:jnz 'pop-values-loop) pop-values-done - - - (:leal (:ebp 8) :esp) - (:popal) ; pop interruptee's registers - (:addl 12 :esp) ; skip stack-hole + + (:movl (:ebp -28) :edi) + (:movl (:ebp -24) :esi) + (:movl (:ebp -20) :ebx) + (:movl (:ebp -16) :edx) + (:movl (:ebp -12) :eax) + (:movl (:ebp -8) :ecx) + + (:leave) + (:addl 12 :esp) + +;;; (:leal (:ebp 8) :esp) +;;; (:popal) ; pop interruptee's registers +;;; (:addl 12 :esp) ; skip stack-hole (:popfl) ; pop EFLAGS (:ret))) ; pop EIP @@ -209,7 +224,7 @@ new-bottom) (break "Stack overload exception ~D at ESP=~@Z with bottom #x~X." number - (+ int-frame (int-frame-index :esp)) + (+ int-frame (int-frame-index :ebp)) old-bottom)) (format *debug-io* "~&Stack-warning: Resetting stack-bottom to #x~X.~%" old-bottom) From ffjeld at common-lisp.net Tue Apr 6 14:45:24 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 10:45:24 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv11579 Modified Files: debugger.lisp Log Message: Some minor improvements here and there to the debugger. Printing safely, among other things. Date: Tue Apr 6 10:45:24 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.4 movitz/losp/x86-pc/debugger.lisp:1.5 --- movitz/losp/x86-pc/debugger.lisp:1.4 Wed Mar 24 08:34:53 2004 +++ movitz/losp/x86-pc/debugger.lisp Tue Apr 6 10:45:24 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.4 2004/03/24 13:34:53 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.5 2004/04/06 14:45:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -140,27 +140,30 @@ (defun stack-frame-numargs (stack-frame) "Try to determine how many arguments was presented to the stack-frame." - (multiple-value-bind (call-site code) - (stack-frame-call-site stack-frame) - (when (and call-site code) - (dolist (map +call-site-numargs-maps+ - (warn "no match at ~D for ~S." - call-site - (stack-frame-funobj (stack-frame-uplink stack-frame)))) - (when (not (mismatch code (cdr map) - :start1 (- call-site (length (cdr map))) - :end1 call-site)) - (return - (cond - ((integerp (car map)) - (car map)) - ((eq :ecx (car map)) + (if (eq (stack-frame-funobj stack-frame) + (load-global-constant complicated-class-of)) + 1 + (multiple-value-bind (call-site code) + (stack-frame-call-site stack-frame) + (when (and call-site code) + (dolist (map +call-site-numargs-maps+ + (warn "no match at ~D for ~S." + call-site + (stack-frame-funobj (stack-frame-uplink stack-frame)))) + (when (not (mismatch code (cdr map) + :start1 (- call-site (length (cdr map))) + :end1 call-site)) + (return (cond - ((= #xb1 (aref code (- call-site 5))) - ;; Assume it's a (:movb x :cl) instruction - (aref code (- call-site 4))) - (t ;; now we should search further for where ecx may be set.. - nil)))))))))) + ((integerp (car map)) + (car map)) + ((eq :ecx (car map)) + (cond + ((= #xb1 (aref code (- call-site 5))) + ;; Assume it's a (:movb x :cl) instruction + (aref code (- call-site 4))) + (t ;; now we should search further for where ecx may be set.. + nil))))))))))) (defun signed8-index (s8) "Convert a 8-bit twos-complement signed integer bitpattern to @@ -371,7 +374,6 @@ (when (match-code-pattern (car pattern-map) code-vector setup-start) (return pattern-map)))))) - (defun print-stack-frame-arglist (stack-frame stack-frame-map &key (numargs (stack-frame-numargs stack-frame)) (edx-p nil)) @@ -440,6 +442,12 @@ (debug-write (stack-frame-ref stack-frame i)))))) (values)) +(defun safe-print-stack-frame-arglist (&rest args) + (declare (dynamic-extent args)) + (handler-case (apply #'print-stack-frame-arglist args) + (t (conditon) + (write-string "#")))) + (defun backtrace (&key ((:frame initial-stack-frame) (or *debugger-invoked-stack-frame* (current-stack-frame))) @@ -447,8 +455,10 @@ ((:fresh-lines *backtrace-do-fresh-lines*) *backtrace-do-fresh-lines*) (conflate *backtrace-do-conflate*) (length *backtrace-length*) + print-returns ((:print-frames *backtrace-print-frames*) *backtrace-print-frames*)) - (let ((*standard-output* *debug-io*) + (let ((*print-safely* t) + (*standard-output* *debug-io*) (*print-length* *backtrace-print-length*) (*print-level* *backtrace-print-level*)) (loop with conflate-count = 0 with count = 0 @@ -465,11 +475,13 @@ (write-string "=")) (write-char #\space)) (t (format t "~& |= "))) + (when print-returns + (format t "{< ~D}" (stack-frame-call-site stack-frame))) (when *backtrace-print-frames* (format t "#x~X " stack-frame)))) (typecase funobj (integer - (let* ((int-frame funobj) + (let* ((int-frame stack-frame) (funobj (int-frame-ref int-frame :esi :lisp))) (if (and conflate ;; When the interrupted function has a stack-frame, conflate it. @@ -522,12 +534,12 @@ ((typep gf 'muerte::standard-gf-instance) (format t "{gf ~S}" (funobj-name gf))) (t (write-string "[not a gf??]"))) - (print-stack-frame-arglist stack-frame map :numargs numargs))) + (safe-print-stack-frame-arglist stack-frame map :numargs numargs))) (t (write name) - (print-stack-frame-arglist stack-frame map - :numargs numargs - :edx-p (eq 'muerte::&edx - (car (funobj-lambda-list funobj))))))) + (safe-print-stack-frame-arglist stack-frame map + :numargs numargs + :edx-p (eq 'muerte::&edx + (car (funobj-lambda-list funobj))))))) (write-char #\)) (when (and (symbolp name) (string= name 'toplevel-function)) From ffjeld at common-lisp.net Tue Apr 6 23:47:26 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 19:47:26 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv21757 Modified Files: los0-gc.lisp Log Message: Fixed nasty bug in new-fast-cons and new-malloc-clumps: Check the space-limit _before_ initializing the to-be-allocated object. Sigh. Date: Tue Apr 6 19:47:26 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.3 movitz/losp/los0-gc.lisp:1.4 --- movitz/losp/los0-gc.lisp:1.3 Tue Apr 6 09:38:21 2004 +++ movitz/losp/los0-gc.lisp Tue Apr 6 19:47:26 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.3 2004/04/06 13:38:21 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.4 2004/04/06 23:47:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -59,27 +59,14 @@ (with-inline-assembly (:returns :eax) (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) (:movl (:edx 2) :ecx) - (:movl :eax (:edx :ecx 2)) - (:movl :ebx (:edx :ecx 6)) - (:leal (:edx :ecx 3) :eax) (:cmpl #x3fff4 :ecx) (:jge '(:sub-program () (:int 112))) - (:addl 8 :ecx) - (:movl :ecx (:edx 2)) - (:ret))) - -(defun new-fast-cons (car cdr) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) car cdr) - (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) - (:movl (:edx 2) :ecx) (:movl :eax (:edx :ecx 2)) (:movl :ebx (:edx :ecx 6)) (:leal (:edx :ecx 3) :eax) - (:cmpl #x3fff4 :ecx) - (:jge '(:sub-program () (:int 112))) (:addl 8 :ecx) - (:movl :ecx (:edx 2)))) + (:movl :ecx (:edx 2)) + (:ret))) (defun new-malloc-clumps (clumps) (check-type clumps (integer 0 200)) From ffjeld at common-lisp.net Wed Apr 7 00:12:24 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 20:12:24 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24352 Added Files: interrupt.lisp Log Message: Moved much stuff from :x86-pc/interrupt to :muerte/interrupt, because it's really a required part of Muerte. Date: Tue Apr 6 20:12:23 2004 Author: ffjeld From ffjeld at common-lisp.net Wed Apr 7 00:12:28 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 20:12:28 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv737 Modified Files: interrupt.lisp Log Message: Moved much stuff from :x86-pc/interrupt to :muerte/interrupt, because it's really a required part of Muerte. Date: Tue Apr 6 20:12:28 2004 Author: ffjeld Index: movitz/losp/x86-pc/interrupt.lisp diff -u movitz/losp/x86-pc/interrupt.lisp:1.8 movitz/losp/x86-pc/interrupt.lisp:1.9 --- movitz/losp/x86-pc/interrupt.lisp:1.8 Tue Apr 6 10:42:11 2004 +++ movitz/losp/x86-pc/interrupt.lisp Tue Apr 6 20:12:28 2004 @@ -10,12 +10,11 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri May 4 18:08:50 2001 ;;;; -;;;; $Id: interrupt.lisp,v 1.8 2004/04/06 14:42:11 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.9 2004/04/07 00:12:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (require :x86-pc/pic8259) -(require :x86-pc/debugger) (provide :x86-pc/interrupt) (in-package muerte.x86-pc) @@ -25,250 +24,6 @@ (:movb #x20 :al) (:outb :al #x20))) -(defmacro stack-word (offset) - `(with-inline-assembly (:returns :eax) - (:movl (:esp ,(* 4 offset)) :eax))) - -(define-compiler-macro int-frame-index (&whole form name &environment env) - (let ((name (and (movitz:movitz-constantp name env) - (movitz:movitz-eval name env)))) - (if (not name) - form - (- 5 (position name - '(:eip :eflags nil :error-code :exception :ebp nil - :ecx :eax :edx :ebx :esi :edi) - #+ignore '(:edi :esi :ebp :esp :ebx :edx :ecx :eax - :exception :error-code - :eip :cs :eflags)))))) - -(defun int-frame-index (name) - (- 5 (position name - '(:eip :eflags nil :error-code :exception :ebp nil - :ecx :eax :edx :ebx :esi :edi)))) - -(define-compiler-macro int-frame-ref (&whole form frame reg type &optional (offset 0) &environment env) - `(memref ,frame (+ (* 4 (int-frame-index ,reg)) ,offset) 0 ,type)) - -(defun int-frame-ref (frame reg type &optional (offset 0)) - (int-frame-ref frame reg type offset)) - -(defun (setf int-frame-ref) (x frame reg type) - (setf (memref frame (* 4 (int-frame-index reg)) 0 type) x)) - -(define-primitive-function muerte::default-interrupt-trampoline () - "Default first-stage interrupt handler." - #.(cl:list* 'with-inline-assembly '(:returns :nothing) - (cl:loop :for i :from 0 :to movitz::+idt-size+ - :append (cl:if (cl:member i '(8 10 11 12 13 14 17)) - `(((5) :pushl ,i) - ((5) :jmp 'ok)) - `(((2) :pushl 0) ; replace Error Code - ((2) :pushl ,i) - ((1) :nop) - ((5) :jmp 'ok))))) - (with-inline-assembly (:returns :multiple-values) - ok - ;; Stack: - ;; 20: Interruptee EFLAGS (later EIP) - ;; 16: Interruptee CS (later EFLAGS) - ;; 12: Interruptee EIP - ;; 8: Error code - ;; 4: Exception number - ;; 0: EBP - (:pushl :ebp) - (:movl :esp :ebp) - (:pushl 0) ; 0 means default-interrupt-trampoline frame - (:pushl :ecx) ; -8 - (:pushl :eax) ; -12 - (:pushl :edx) ; -16 - (:pushl :ebx) ; -20 - (:pushl :esi) ; -24 - (:pushl :edi) ; -28 - - ;; rearrange stack for return - (:movl (:ebp 12) :eax) ; load return address - (:movl (:ebp 20) :ebx) ; load EFLAGS - (:movl :ebx (:ebp 16)) ; EFLAGS at next-to-bottom of stack - (:movl :eax (:ebp 20)) ; return address at bottom of stack - - (:xorl :eax :eax) ; Ensure safe value - (:xorl :edx :edx) ; Ensure safe value - - (:movl ':nil-value :edi) ; We want NIL! - - (:pushl (:ebp 16)) ; EFLAGS - (:pushl :cs) ; push CS - (:call (:pc+ 0)) ; push EIP. - ;; Now add a few bytes to the on-stack EIP so the iret goes to - ;; *DEST* below. - ((4) :addl 5 (:esp)) ; 4 bytes - ((1) :iretd) ; 1 byte - - ;; *DEST* iret branches to here. - ;; we're now in the context of the interruptee. - -;;; (:pushl :eax) ; fake stack-frame return address -;;; (:pushl :ebp) ; set up fake stack-frame -;;; (:movl :esp :ebp) ; (GIVES EBP OFFSET 8 RELATIVE TO NUMBERS ABOVE!!) -;;; (:pushl :edi) ; A fake "funobj" for the fake stack-frame.. -;;; ; ..the int-frame will be put here shortly. - - ;; Save/push thread-local values - (:locally (:movl (:edi (:edi-offset num-values)) :ecx)) - (:jecxz 'push-values-done) - (:leal (:edi #.(movitz::global-constant-offset 'values)) :eax) - push-values-loop - (:locally (:pushl (:eax))) - (:addl 4 :eax) - (:subl 1 :ecx) - (:jnz 'push-values-loop) - push-values-done - (:locally (:pushl (:edi (:edi-offset num-values)))) - - ;; call handler - (:movl (:ebp 4) :ebx) ; interrupt number into EBX - (:locally (:movl (:edi (:edi-offset interrupt-handlers)) :eax)) - (:movl (:eax 2 (:ebx 4)) :eax) ; symbol at (aref EBX interrupt-handlers) into :esi - (:leal (:eax -7) :ecx) - (:testb 7 :cl) - (:jnz 'skip-interrupt-handler) ; if it's not a symbol, never mind. - (:movl (:eax #.(movitz::slot-offset 'movitz::movitz-symbol 'movitz::function-value)) - :esi) ; load new funobj from symbol into ESI - (:movl :ebp :ebx) ; pass INT-frame as arg1 - ;; (:movl :ebx (:ebp -4)) ; put INT-frame as our fake stack-frame's funobj. - (:movl (:ebp 4) :eax) ; pass interrupt number as arg 0. - (:shll #.movitz::+movitz-fixnum-shift+ :eax) - (:call (:esi #.(movitz::slot-offset 'movitz::movitz-funobj 'movitz::code-vector%2op))) - - skip-interrupt-handler - ;; Restore thread-local values - (:popl :ecx) - (:locally (:movl :ecx (:edi (:edi-offset num-values)))) - (:jecxz 'pop-values-done) - pop-values-loop - ;; ((:fs-override) :popl (:edi #.(movitz::global-constant-offset 'values) (:ecx 4) -4)) - (:locally (:popl (:edi (:edi-offset values) (:ecx 4) -4))) - (:subl 1 :ecx) - (:jnz 'pop-values-loop) - pop-values-done - - (:movl (:ebp -28) :edi) - (:movl (:ebp -24) :esi) - (:movl (:ebp -20) :ebx) - (:movl (:ebp -16) :edx) - (:movl (:ebp -12) :eax) - (:movl (:ebp -8) :ecx) - - (:leave) - (:addl 12 :esp) - -;;; (:leal (:ebp 8) :esp) -;;; (:popal) ; pop interruptee's registers -;;; (:addl 12 :esp) ; skip stack-hole - (:popfl) ; pop EFLAGS - (:ret))) ; pop EIP - -(defvar *last-interrupt-frame* nil) - -(defun muerte::interrupt-default-handler (number int-frame) - (declare (muerte::without-check-stack-limit)) - (macrolet ((@ (fixnum-address &optional (type :lisp)) - "Dereference the fixnum-address." - `(memref ,fixnum-address 0 0 ,type))) - (let (($eip (+ int-frame (int-frame-index :eip))) - ($eax (+ int-frame (int-frame-index :eax))) - ($ebx (+ int-frame (int-frame-index :ebx))) - ($ecx (+ int-frame (int-frame-index :ecx))) - ($edx (+ int-frame (int-frame-index :edx))) - ($esi (+ int-frame (int-frame-index :esi))) - (*last-interrupt-frame* int-frame)) - (block nil - (case number - (0 (error "Division by zero.")) - (3 (break "Break instruction at ~@Z." $eip)) - (6 (error "Illegal instruction at ~@Z." $eip)) - (13 (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z" - $eip - (int-frame-ref int-frame :error-code :unsigned-byte32) - $eax $ebx $ecx)) - (68 (warn "EIP: ~@Z EAX: ~@Z EBX: ~@Z ECX: ~@Z EDX: ~@Z" - $eip $eax $ebx $ecx $edx) - (dotimes (i 100000) - (with-inline-assembly (:returns :nothing) (:nop)))) - (67 (muerte.debug:backtrace :fresh-lines nil :length 6) - (dotimes (i 100000) - (with-inline-assembly (:returns :nothing) (:nop)))) - (66 (error "Unspecified type error at ~@Z in ~S with EAX=~@Z, ECX=~@Z." - $eip (@ (+ int-frame (int-frame-index :esi))) - $eax $ecx)) - (62 (error "Trying to save too many values: ~@Z." $ecx)) - ((5 55) - (let* ((stack (muerte::%run-time-context-slot 'movitz::stack-vector)) - (old-bottom (muerte::stack-bottom)) - (real-bottom (- (object-location stack) 2)) - (stack-left (- old-bottom real-bottom)) - (new-bottom (cond - ((< stack-left 10) - (princ "Halting CPU due to stack exhaustion.") - (muerte::halt-cpu)) - ((<= stack-left 256) - (format *debug-io* - "~&This is your LAST chance to pop off stack.~%") - real-bottom) - (t (+ real-bottom (truncate stack-left 2)))))) ; Cushion the fall.. - (unwind-protect - (progn - (setf (muerte::stack-bottom) new-bottom) - (format *debug-io* "~&Stack-warning: Bumped stack-bottom by ~D to #x~X.~%" - (- old-bottom new-bottom) - new-bottom) - (break "Stack overload exception ~D at ESP=~@Z with bottom #x~X." - number - (+ int-frame (int-frame-index :ebp)) - old-bottom)) - (format *debug-io* "~&Stack-warning: Resetting stack-bottom to #x~X.~%" - old-bottom) - (setf (muerte::stack-bottom) old-bottom)))) - (69 - (error "Not a function: ~S" (@ $edx))) - (70 - (error "[EIP=~@Z] Index ~@Z out of bounds ~@Z for ~S." $eip $ecx $ebx (@ $eax))) - (98 - (let ((name (@ $ecx))) - (when (symbolp name) - (error 'undefined-function :name name)))) - (99 - (let ((name (@ $edx))) - (when (symbolp name) - (error 'unbound-variable :name name)))) - ((100);; 101 102 103 104 105) - (let ((funobj (@ (+ int-frame (int-frame-index :esi)))) - (code (int-frame-ref int-frame :ecx :unsigned-byte8))) - (error 'muerte:wrong-argument-count - :function funobj - :argument-count (if (logbitp 7 code) - (ash (int-frame-ref int-frame :ecx :unsigned-byte32) - -24) - code)))) - (108 - (error 'throw-error :tag (@ $eax))) - (110 - ;; (print-dynamic-context); what's this? - (throw :debugger nil)) - (112 - (setf (%run-time-context-slot 'nursery-space) - (memref (%run-time-context-slot 'nursery-space) -6 3 :lisp)) - (error "Out of memory. Please take out the garbage.")) - (t (funcall (if (< 16 number 50) #'warn #'error) - "Exception occurred: ~D, EIP: ~@Z, EAX: ~@Z, ECX: ~@Z, ESI: ~@Z" - number $eip $eax $ecx $esi))) - nil)))) - - -;;; (with-inline-assembly (:returns :nothing) (:movb #x47 (#xb8045)) -;;; (:addb #x01 (#xb8044)))) - - (defun idt-init () (init-pic8259 32 40) (setf (pic8259-irq-mask) #xffff) @@ -284,24 +39,6 @@ (setf (pic8259-irq-mask) #xfffe) (with-inline-assembly (:returns :nothing) (:sti))) -(defun cli () - (with-inline-assembly (:returns :nothing) - (:cli))) - -(defun sti () - (with-inline-assembly (:returns :nothing) - (:sti))) - -(defun interrupt-handler (n) - (let ((vector (load-global-constant interrupt-handlers))) - (svref vector n))) - -(defun (setf interrupt-handler) (handler n) - (check-type handler symbol) - (assert (fboundp handler)) - (let ((vector (load-global-constant interrupt-handlers))) - (setf (svref vector n) handler))) - (defparameter *timer-counter* 0) (defun timer-handler (number int-frame) @@ -312,31 +49,3 @@ (pic8259-end-of-interrupt 0)) -(define-primitive-function primitive-software-interrupt () - "A primitive code-vector that generates software interrupts." - (macrolet ((make-software-interrupt-code () - (cons 'progn - (loop for vector from 0 to 255 - collect `(with-inline-assembly (:returns :nothing) - ;; Each code-entry is 2+1+1=4 bytes. - ((2) :int ,vector) - ((1) :ret) - ((1) :nop)))))) - (make-software-interrupt-code))) - -(defun software-interrupt (interrupt-vector &optional (eax 0) (ebx 0)) - "Generate software-interrupt number ." - ;; The problem now is that the x86 INT instruction only takes an - ;; immediate argument. - ;; Hence the primitive-function primitive-software-interrupt. - (check-type interrupt-vector (unsigned-byte 8)) - (let ((code-vector (symbol-value 'primitive-software-interrupt))) - (check-type code-vector vector) - (with-inline-assembly-case () - (do-case (t :nothing) - (:compile-two-forms (:ecx :edx) interrupt-vector code-vector) - (:leal (:edx :ecx 2) :ecx) - (:compile-two-forms (:eax :ebx) eax ebx) - (:shrl 2 :eax) - (:shrl 2 :ebx) - (:call :ecx))))) From ffjeld at common-lisp.net Wed Apr 7 00:13:02 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 20:13:02 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/common-lisp.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15041 Modified Files: common-lisp.lisp Log Message: Include :muerte/interrupt. Date: Tue Apr 6 20:13:02 2004 Author: ffjeld Index: movitz/losp/muerte/common-lisp.lisp diff -u movitz/losp/muerte/common-lisp.lisp:1.3 movitz/losp/muerte/common-lisp.lisp:1.4 --- movitz/losp/muerte/common-lisp.lisp:1.3 Mon Mar 29 09:33:01 2004 +++ movitz/losp/muerte/common-lisp.lisp Tue Apr 6 20:13:02 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:41:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: common-lisp.lisp,v 1.3 2004/03/29 14:33:01 ffjeld Exp $ +;;;; $Id: common-lisp.lisp,v 1.4 2004/04/07 00:13:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -43,6 +43,7 @@ (require :muerte/eval) (require :muerte/los-closette) (require :muerte/environment) +(require :muerte/interrupt) (require :muerte/streams) (require :muerte/restarts) (require :muerte/conditions) From ffjeld at common-lisp.net Wed Apr 7 00:15:06 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 20:15:06 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8835 Modified Files: memref.lisp Log Message: Improve memref a bit more. Date: Tue Apr 6 20:15:05 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.10 movitz/losp/muerte/memref.lisp:1.11 --- movitz/losp/muerte/memref.lisp:1.10 Tue Apr 6 10:25:44 2004 +++ movitz/losp/muerte/memref.lisp Tue Apr 6 20:15:02 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.10 2004/04/06 14:25:44 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.11 2004/04/07 00:15:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -182,15 +182,19 @@ (:jg '(:sub-program () (:int 4))))))))) (:lisp (cond - ((and (eq 0 index) (eq 0 offset)) + ((and (eql 0 index) (eql 0 offset)) `(with-inline-assembly (:returns :register) (:compile-form (:result-mode :register) ,object) (:movl ((:result-register) ,(offset-by 4)) (:result-register)))) - ((eq 0 offset) + ((eql 0 offset) `(with-inline-assembly (:returns :eax) (:compile-two-forms (:eax :ecx) ,object ,index) ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx)) + (:movl (:eax :ecx ,(offset-by 4)) :eax))) + ((eql 0 index) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :untagged-fixnum-ecx) ,object ,offset) (:movl (:eax :ecx ,(offset-by 4)) :eax))) (t (assert (not (movitz:movitz-constantp offset env))) (assert (not (movitz:movitz-constantp index env))) From ffjeld at common-lisp.net Wed Apr 7 00:15:45 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 20:15:45 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv31200 Modified Files: primitive-functions.lisp Log Message: Minor edits to comments. Date: Tue Apr 6 20:15:45 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.6 movitz/losp/muerte/primitive-functions.lisp:1.7 --- movitz/losp/muerte/primitive-functions.lisp:1.6 Sun Mar 28 20:09:46 2004 +++ movitz/losp/muerte/primitive-functions.lisp Tue Apr 6 20:15:44 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.6 2004/03/29 01:09:46 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.7 2004/04/07 00:15:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -90,13 +90,13 @@ ;;; Dynamic binding: -;;; 12: parent (NIL == #x0) +;;; 12: parent (no parent == #x0) ;;; 8: value ;;; 4: tag = #:unbound (unique value that cannot be a catch tag) ;;; 0: binding name/symbol ;;; Catch exit-point: -;;; 12: parent (NIL == #x0) +;;; 12: parent (no parent == #x0) ;;; 8: eip ;;; 4: catch tag object/word ;;; 0: ebp/stack-frame From ffjeld at common-lisp.net Wed Apr 7 00:16:38 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 20:16:38 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27042 Modified Files: scavenge.lisp Log Message: Much improved support for scavenging stacks with interrupts on them. Date: Tue Apr 6 20:16:38 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.4 movitz/losp/muerte/scavenge.lisp:1.5 --- movitz/losp/muerte/scavenge.lisp:1.4 Tue Apr 6 10:33:10 2004 +++ movitz/losp/muerte/scavenge.lisp Tue Apr 6 20:16:38 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.4 2004/04/06 14:33:10 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.5 2004/04/07 00:16:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -96,11 +96,80 @@ and frame = (stack-frame-uplink start-stack-frame) then (stack-frame-uplink frame) while (plusp frame) do (let ((funobj (stack-frame-funobj frame t))) - (etypecase funobj - (integer - (error "Don't know how to scavenge across an interrupt frame.")) + #+ignore + (format t "~&fill ~S frame for ~S" + (aref (%run-time-context-slot 'nursery-space) 0) + funobj) + (typecase funobj (function (assert (= 0 (funobj-frame-num-unboxed funobj))) - (map-heap-words function (+ nether-frame 2) frame))))) + (map-heap-words function (+ nether-frame 2) frame)) + ((eql 0) + ;; 1. Scavenge the interrupt-frame + (map-heap-words function + (+ nether-frame 2) + (+ frame (int-frame-index :ecx))) + (let* ((interrupt-frame frame) + (interrupted-eip-loc + (int-frame-ref interrupt-frame :eip :signed-byte30+2))) + ;; 2. Pop to interrupted frame + (setf nether-frame frame + frame (stack-frame-uplink frame)) + (let ((interrupted-funobj (stack-frame-funobj frame)) + (interrupted-esp (+ interrupt-frame 6))) + (assert (typep interrupted-funobj 'function) () + "Interrupted frame was not a normal function: ~S" + interrupted-funobj) + ;; 3. Scavenge the interrupted frame, skipping EFLAGS etc. + (if (location-in-object-p (funobj-code-vector interrupted-funobj) + interrupted-eip-loc) + ;; The simple case: The interruptee matches interrupted EIP + (map-heap-words function interrupted-esp frame) + (let ((primitive-function-vector + (stack-frame-primitive-funcall interrupted-funobj + interrupted-esp + interrupted-eip-loc))) + (if primitive-function-vector + ;; Next simplest case: The interruptee was in a primitive-function, + ;; with the return-address at top of stack. + (map-heap-words function (1+ interrupted-esp) frame) + (error "Don't know how to scavenge across interrupt frame at ~S." + interrupt-frame))))))) + (t (error "Don't know how to scavenge across a frame of kind ~S." funobj))))) (values)) +(defparameter *primitive-funcall-patterns* + '(#xff #x57 (:function-offset :signed8))) + +(defun stack-frame-primitive-funcall (funobj stack-location eip-location) + (let ((return-address (memref stack-location 0 0 :unsigned-byte32)) + (code-vector (funobj-code-vector funobj))) + (multiple-value-bind (return-location return-delta) + (truncate return-address #.movitz:+movitz-fixnum-factor+) + (if (not (location-in-object-p code-vector return-location)) + nil + (multiple-value-bind (success-p type code) + (match-code-pattern *primitive-funcall-patterns* + code-vector (+ (* (- return-location + (object-location code-vector)) + #.movitz:+movitz-fixnum-factor+) + return-delta + -3 -8) + :function-offset) + (if (not success-p) + (warn "mismatch in ~S at ~D from #x~X in ~Z." + funobj + (+ (* (- return-location + (object-location code-vector)) + #.movitz:+movitz-fixnum-factor+) + return-delta + -3 -8) + return-address code-vector) + (let* ((offset (ecase type + (:signed8 + (if (not (logbitp 7 code)) code (- code 256))))) + (primitive-function (%word-offset (%run-time-context-ref offset) -2))) + (check-type primitive-function vector-u8) + (if (not (location-in-object-p primitive-function eip-location)) + nil + primitive-function)))))))) From ffjeld at common-lisp.net Wed Apr 7 00:17:19 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 20:17:19 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27042 Modified Files: typep.lisp Log Message: An explicit error is better than an ecase error in typep. Date: Tue Apr 6 20:17:19 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.5 movitz/losp/muerte/typep.lisp:1.6 --- movitz/losp/muerte/typep.lisp:1.5 Mon Mar 29 09:34:20 2004 +++ movitz/losp/muerte/typep.lisp Tue Apr 6 20:17:19 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.5 2004/03/29 14:34:20 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.6 2004/04/07 00:17:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -285,7 +285,7 @@ (defun typep (object type-specifier) (block nil - (etypecase type-specifier + (typecase type-specifier (symbol (let ((typep-function (gethash type-specifier *simple-typespecs*))) (when typep-function From ffjeld at common-lisp.net Wed Apr 7 00:18:57 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 20:18:57 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv31649 Modified Files: run-time-context.lisp Log Message: Added %run-time-context-ref function. Date: Tue Apr 6 20:18:57 2004 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.4 movitz/losp/muerte/run-time-context.lisp:1.5 --- movitz/losp/muerte/run-time-context.lisp:1.4 Wed Mar 31 11:47:40 2004 +++ movitz/losp/muerte/run-time-context.lisp Tue Apr 6 20:18:57 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.4 2004/03/31 16:47:40 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.5 2004/04/07 00:18:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -116,6 +116,18 @@ (memref context (+ -6 4) index8 :unsigned-byte8) (ldb (byte 8 16) value) (memref context (+ -6 7) index8 :unsigned-byte8) (ldb (byte 6 24) value))))) value)) + +(defun %run-time-context-ref (edi-offset) + "Get a run-time-context slot by its EDI-relative offset." + (with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) edi-offset) + (:leal (:eax #.(cl:* 1 movitz:+movitz-fixnum-factor+)) :ecx) + (:sarl #.movitz:+movitz-fixnum-shift+ :ecx) + (:testb 3 :cl) + (:jnz '(:sub-program () + (:compile-form (:result-mode :ignore) + (error "Illegal edi-offset ~S" edi-offset)))) + (:locally (:movl (:edi :ecx -1) :eax)))) (defun clone-run-time-context (&key (parent (current-run-time-context)) (name :anonymous)) From ffjeld at common-lisp.net Wed Apr 7 00:20:13 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 20:20:13 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17952 Modified Files: basic-functions.lisp Log Message: Added object-location-offset operator, but I'm not really sure it's useful afterall, so I commented it out for now. Date: Tue Apr 6 20:20:13 2004 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.9 movitz/losp/muerte/basic-functions.lisp:1.10 --- movitz/losp/muerte/basic-functions.lisp:1.9 Wed Mar 31 21:10:38 2004 +++ movitz/losp/muerte/basic-functions.lisp Tue Apr 6 20:20:12 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.9 2004/04/01 02:10:38 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.10 2004/04/07 00:20:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -340,6 +340,18 @@ (defun object-location (object) "The location is the object's address divided by fixnum-factor." (object-location object)) + +;;;(define-compiler-macro object-location-offset (object) +;;; "The offset from the object's location to it's true address." +;;; `(with-inline-assembly (:returns :register) +;;; (:compile-form (:result-mode :register) ,object) +;;; (:shll ,movitz:+movitz-fixnum-shift+ (:result-register)) +;;; (:andl ,(* movitz:+movitz-fixnum-factor+ +;;; movitz:+movitz-fixnum-zmask+) +;;; (:result-register)))) +;;; +;;;(defun object-location-offset (object) +;;; (object-location-offset object)) (defun halt-cpu () (halt-cpu)) From ffjeld at common-lisp.net Wed Apr 7 00:21:29 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 20:21:29 -0400 Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11575 Modified Files: special-operators.lisp Log Message: There's something funny in my lisp-mode that sometimes causes comments to be messed up like this.. Date: Tue Apr 6 20:21:29 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.17 movitz/special-operators.lisp:1.18 --- movitz/special-operators.lisp:1.17 Wed Mar 31 11:33:25 2004 +++ movitz/special-operators.lisp Tue Apr 6 20:21:28 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.17 2004/03/31 16:33:25 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.18 2004/04/07 00:21:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -711,9 +711,8 @@ as sub-form-result-mode = buried-result-modes then (or (cdr sub-form-result-mode) sub-form-result-mode) - as current-result-mode = (if (endp (cdr sub-form)) all but the - ;; last form have result-mode as - ;; declared + as current-result-mode = (if (endp (cdr sub-form)) + ;; all but the last form have result-mode as declared result-mode (car sub-form-result-mode)) as last-form-p = (endp (cdr sub-form)) From ffjeld at common-lisp.net Wed Apr 7 00:34:07 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 20:34:07 -0400 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv19936 Modified Files: packages.lisp Log Message: More symbols added. Date: Tue Apr 6 20:34:07 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.13 movitz/packages.lisp:1.14 --- movitz/packages.lisp:1.13 Tue Apr 6 10:35:14 2004 +++ movitz/packages.lisp Tue Apr 6 20:34:06 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.13 2004/04/06 14:35:14 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.14 2004/04/07 00:34:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1104,19 +1104,21 @@ #:*print-safely* - stack-ref - with-each-dynamic-context - stack-frame-uplink - current-stack-frame - current-dynamic-context - stack-frame-funobj - stack-frame-call-site - stack-frame-ref - check-stack-limit + #:stack-ref + #:with-each-dynamic-context + #:stack-frame-uplink + #:current-stack-frame + #:current-dynamic-context + #:stack-frame-funobj + #:stack-frame-call-site + #:stack-frame-ref + #:check-stack-limit + #:interrupt-frame-ref + #:interrupt-handler - *build-number* - *error-no-condition-for-debugger* - formatted-error + #:*build-number* + #:*error-no-condition-for-debugger* + #:formatted-error #:package-object-use-list #:package-object-internal-symbols @@ -1289,6 +1291,7 @@ #:+movitz-fixnum-factor+ #:+movitz-fixnum-shift+ + #:+movitz-fixnum-zmask+ #:+scan-skip-word+ #:constant0 From ffjeld at common-lisp.net Wed Apr 7 00:34:48 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 20:34:48 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18401 Modified Files: interrupt.lisp Log Message: Renamed int-frame- to interrupt-frame- Date: Tue Apr 6 20:34:47 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.1 movitz/losp/muerte/interrupt.lisp:1.2 --- movitz/losp/muerte/interrupt.lisp:1.1 Tue Apr 6 20:12:23 2004 +++ movitz/losp/muerte/interrupt.lisp Tue Apr 6 20:34:47 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.1 2004/04/07 00:12:23 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.2 2004/04/07 00:34:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,7 +22,7 @@ `(with-inline-assembly (:returns :eax) (:movl (:esp ,(* 4 offset)) :eax))) -(define-compiler-macro int-frame-index (&whole form name &environment env) +(define-compiler-macro interrupt-frame-index (&whole form name &environment env) (let ((name (and (movitz:movitz-constantp name env) (movitz:movitz-eval name env)))) (if (not name) @@ -31,19 +31,20 @@ '(nil :eflags :eip :error-code :exception :ebp nil :ecx :eax :edx :ebx :esi :edi)))))) -(defun int-frame-index (name) +(defun interrupt-frame-index (name) (- 5 (position name '(nil :eflags :eip :error-code :exception :ebp nil :ecx :eax :edx :ebx :esi :edi)))) -(define-compiler-macro int-frame-ref (&whole form frame reg type &optional (offset 0) &environment env) - `(memref ,frame (+ (* 4 (int-frame-index ,reg)) ,offset) 0 ,type)) +(define-compiler-macro interrupt-frame-ref (&whole form frame reg type &optional (offset 0) + &environment env) + `(memref ,frame (+ (* 4 (interrupt-frame-index ,reg)) ,offset) 0 ,type)) -(defun int-frame-ref (frame reg type &optional (offset 0)) - (int-frame-ref frame reg type offset)) +(defun interrupt-frame-ref (frame reg type &optional (offset 0)) + (interrupt-frame-ref frame reg type offset)) -(defun (setf int-frame-ref) (x frame reg type) - (setf (memref frame (* 4 (int-frame-index reg)) 0 type) x)) +(defun (setf interrupt-frame-ref) (x frame reg type) + (setf (memref frame (* 4 (interrupt-frame-index reg)) 0 type) x)) (define-primitive-function default-interrupt-trampoline () "Default first-stage interrupt handler." @@ -118,8 +119,8 @@ (:jnz 'skip-interrupt-handler) ; if it's not a symbol, never mind. (:movl (:eax #.(movitz::slot-offset 'movitz::movitz-symbol 'movitz::function-value)) :esi) ; load new funobj from symbol into ESI - (:movl :ebp :ebx) ; pass INT-frame as arg1 - ;; (:movl :ebx (:ebp -4)) ; put INT-frame as our fake stack-frame's funobj. + (:movl :ebp :ebx) ; pass interrupt-frame as arg1 + ;; (:movl :ebx (:ebp -4)) ; put interrupt-frame as our fake stack-frame's funobj. (:movl (:ebp 4) :eax) ; pass interrupt number as arg 0. (:shll #.movitz::+movitz-fixnum-shift+ :eax) (:call (:esi #.(movitz::slot-offset 'movitz::movitz-funobj 'movitz::code-vector%2op))) @@ -150,18 +151,18 @@ (defvar *last-interrupt-frame* nil) -(defun interrupt-default-handler (number int-frame) +(defun interrupt-default-handler (number interrupt-frame) (declare (without-check-stack-limit)) (macrolet ((@ (fixnum-address &optional (type :lisp)) "Dereference the fixnum-address." `(memref ,fixnum-address 0 0 ,type))) - (let (($eip (+ int-frame (int-frame-index :eip))) - ($eax (+ int-frame (int-frame-index :eax))) - ($ebx (+ int-frame (int-frame-index :ebx))) - ($ecx (+ int-frame (int-frame-index :ecx))) - ($edx (+ int-frame (int-frame-index :edx))) - ($esi (+ int-frame (int-frame-index :esi))) - (*last-interrupt-frame* int-frame)) + (let (($eip (+ interrupt-frame (interrupt-frame-index :eip))) + ($eax (+ interrupt-frame (interrupt-frame-index :eax))) + ($ebx (+ interrupt-frame (interrupt-frame-index :ebx))) + ($ecx (+ interrupt-frame (interrupt-frame-index :ecx))) + ($edx (+ interrupt-frame (interrupt-frame-index :edx))) + ($esi (+ interrupt-frame (interrupt-frame-index :esi))) + (*last-interrupt-frame* interrupt-frame)) (block nil (case number (0 (error "Division by zero.")) @@ -169,7 +170,7 @@ (6 (error "Illegal instruction at ~@Z." $eip)) (13 (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z" $eip - (int-frame-ref int-frame :error-code :unsigned-byte32) + (interrupt-frame-ref interrupt-frame :error-code :unsigned-byte32) $eax $ebx $ecx)) (68 (warn "EIP: ~@Z EAX: ~@Z EBX: ~@Z ECX: ~@Z EDX: ~@Z" $eip $eax $ebx $ecx $edx) @@ -179,7 +180,7 @@ (dotimes (i 100000) (with-inline-assembly (:returns :nothing) (:nop)))) (66 (error "Unspecified type error at ~@Z in ~S with EAX=~@Z, ECX=~@Z." - $eip (@ (+ int-frame (int-frame-index :esi))) + $eip (@ (+ interrupt-frame (interrupt-frame-index :esi))) $eax $ecx)) (62 (error "Trying to save too many values: ~@Z." $ecx)) ((5 55) @@ -204,7 +205,7 @@ new-bottom) (break "Stack overload exception ~D at ESP=~@Z with bottom #x~X." number - (+ int-frame (int-frame-index :ebp)) + (+ interrupt-frame (interrupt-frame-index :ebp)) old-bottom)) (format *debug-io* "~&Stack-warning: Resetting stack-bottom to #x~X.~%" old-bottom) @@ -222,12 +223,13 @@ (when (symbolp name) (error 'unbound-variable :name name)))) ((100);; 101 102 103 104 105) - (let ((funobj (@ (+ int-frame (int-frame-index :esi)))) - (code (int-frame-ref int-frame :ecx :unsigned-byte8))) + (let ((funobj (@ (+ interrupt-frame (interrupt-frame-index :esi)))) + (code (interrupt-frame-ref interrupt-frame :ecx :unsigned-byte8))) (error 'wrong-argument-count :function funobj :argument-count (if (logbitp 7 code) - (ash (int-frame-ref int-frame :ecx :unsigned-byte32) + (ash (interrupt-frame-ref interrupt-frame + :ecx :unsigned-byte32) -24) code)))) (108 From ffjeld at common-lisp.net Wed Apr 7 00:34:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 20:34:52 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27542 Modified Files: scavenge.lisp Log Message: Renamed int-frame- to interrupt-frame- Date: Tue Apr 6 20:34:52 2004 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.5 movitz/losp/muerte/scavenge.lisp:1.6 --- movitz/losp/muerte/scavenge.lisp:1.5 Tue Apr 6 20:16:38 2004 +++ movitz/losp/muerte/scavenge.lisp Tue Apr 6 20:34:52 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.5 2004/04/07 00:16:38 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.6 2004/04/07 00:34:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -108,10 +108,10 @@ ;; 1. Scavenge the interrupt-frame (map-heap-words function (+ nether-frame 2) - (+ frame (int-frame-index :ecx))) + (+ frame (interrupt-frame-index :ecx))) (let* ((interrupt-frame frame) (interrupted-eip-loc - (int-frame-ref interrupt-frame :eip :signed-byte30+2))) + (interrupt-frame-ref interrupt-frame :eip :signed-byte30+2))) ;; 2. Pop to interrupted frame (setf nether-frame frame frame (stack-frame-uplink frame)) From ffjeld at common-lisp.net Wed Apr 7 00:34:57 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 20:34:57 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv1866 Modified Files: debugger.lisp Log Message: Renamed int-frame- to interrupt-frame- Date: Tue Apr 6 20:34:57 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.5 movitz/losp/x86-pc/debugger.lisp:1.6 --- movitz/losp/x86-pc/debugger.lisp:1.5 Tue Apr 6 10:45:24 2004 +++ movitz/losp/x86-pc/debugger.lisp Tue Apr 6 20:34:57 2004 @@ -10,14 +10,14 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.5 2004/04/06 14:45:24 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.6 2004/04/07 00:34:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (provide :x86-pc/debugger) -(defpackage muerte.debug - (:use #:muerte.cl #:muerte #:muerte.x86-pc) +(defpackage muerte + ;; (:use #:muerte.cl #:muerte #:muerte.x86-pc) (:export #:*debugger-function* #:*debugger-condition* #:*backtrace-conflate-names* @@ -33,7 +33,7 @@ #:backtrace )) -(in-package muerte.debug) +(in-package muerte) (defparameter *backtrace-be-spartan-p* nil) @@ -481,8 +481,8 @@ (format t "#x~X " stack-frame)))) (typecase funobj (integer - (let* ((int-frame stack-frame) - (funobj (int-frame-ref int-frame :esi :lisp))) + (let* ((interrupt-frame stack-frame) + (funobj (interrupt-frame-ref interrupt-frame :esi :lisp))) (if (and conflate ;; When the interrupted function has a stack-frame, conflate it. (typep funobj 'function) @@ -492,18 +492,19 @@ (incf count) (print-leadin stack-frame count conflate-count) (setf conflate-count 0) - (let ((exception (int-frame-ref int-frame :exception :unsigned-byte32)) - (eip (int-frame-ref int-frame :eip :unsigned-byte32))) + (let ((exception (interrupt-frame-ref interrupt-frame :exception + :unsigned-byte32)) + (eip (interrupt-frame-ref interrupt-frame :eip :unsigned-byte32))) (typecase funobj (function (let ((delta (code-vector-offset (funobj-code-vector funobj) eip))) (if delta (format t "{Interrupt ~D in ~W at offset ~D. [#x~X]}" - exception (funobj-name funobj) delta int-frame) + exception (funobj-name funobj) delta interrupt-frame) (format t "{Interrupt ~D in ~W at EIP=#x~X. [#x~X]}" - exception (funobj-name funobj) eip int-frame)))) + exception (funobj-name funobj) eip interrupt-frame)))) (t (format t "{Interrupt ~D with ESI=#x~Z and EIP=#x~X. [#x~X]}" - exception funobj eip int-frame)))))))) + exception funobj eip interrupt-frame)))))))) (function (let ((name (funobj-name funobj))) (cond From ffjeld at common-lisp.net Wed Apr 7 00:35:51 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 20:35:51 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv20592 Modified Files: los0.lisp Log Message: Minor edits. Date: Tue Apr 6 20:35:51 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.10 movitz/losp/los0.lisp:1.11 --- movitz/losp/los0.lisp:1.10 Tue Apr 6 09:36:42 2004 +++ movitz/losp/los0.lisp Tue Apr 6 20:35:51 2004 @@ -9,14 +9,13 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.10 2004/04/06 13:36:42 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.11 2004/04/07 00:35:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (provide :los0 :load-priority 0) (require :common-lisp) -(require :x86-pc/interrupt) (require :x86-pc/all) (require :x86-pc/io-space) (require :x86-pc/ne2k) @@ -37,7 +36,6 @@ muerte.ip6 muerte.ip4 muerte.mop - muerte.debug #+ignore muerte.x86-pc.serial)) (require :los0-gc) From ffjeld at common-lisp.net Wed Apr 7 00:45:54 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 20:45:54 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv13793 Modified Files: los0-gc.lisp Log Message: Added a handler for the out-of-memory exception to automatically call stop-and-copy. So now the GC architecture should in principle be complete! Date: Tue Apr 6 20:45:54 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.4 movitz/losp/los0-gc.lisp:1.5 --- movitz/losp/los0-gc.lisp:1.4 Tue Apr 6 19:47:26 2004 +++ movitz/losp/los0-gc.lisp Tue Apr 6 20:45:54 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.4 2004/04/06 23:47:26 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.5 2004/04/07 00:45:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -57,10 +57,13 @@ (define-primitive-function new-fast-cons () "Allocate a cons cell from nursery-space." (with-inline-assembly (:returns :eax) + retry-cons (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) (:movl (:edx 2) :ecx) (:cmpl #x3fff4 :ecx) - (:jge '(:sub-program () (:int 112))) + (:jge '(:sub-program () + (:int 112) + (:jmp 'retry-cons))) (:movl :eax (:edx :ecx 2)) (:movl :ebx (:edx :ecx 6)) (:leal (:edx :ecx 3) :eax) @@ -92,6 +95,11 @@ (:jb 'init-loop) (:movl #.(movitz:tag :infant-object) (:ebx -2)))) +(defun los0-handle-out-of-memory (exception interrupt-frame) + (declare (ignore exception interrupt-frame)) + (format t "~&;; Handling out-of-memory exception..") + (stop-and-copy)) + (defun install-los0-consing () (setf (%run-time-context-slot 'nursery-space) (allocate-duo-space)) @@ -104,6 +112,7 @@ (symbol-function 'new-malloc-clumps)) (setf (symbol-function 'new-malloc-clumps) old-malloc)) + (setf (interrupt-handler 112) 'los0-handle-out-of-memory) (values)) (defun install-old-consing () From ffjeld at common-lisp.net Wed Apr 7 01:13:41 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 06 Apr 2004 21:13:41 -0400 Subject: [movitz-cvs] CVS update: public_html/movitz.html Message-ID: Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv13569 Modified Files: movitz.html Log Message: Slight change to description of GC: interrupt frames are now somewhat supported. Date: Tue Apr 6 21:13:41 2004 Author: ffjeld Index: public_html/movitz.html diff -u public_html/movitz.html:1.6 public_html/movitz.html:1.7 --- public_html/movitz.html:1.6 Tue Mar 30 03:35:32 2004 +++ public_html/movitz.html Tue Apr 6 21:13:41 2004 @@ -10,7 +10,7 @@ Author: Frode Vatvedt Fjeld Created at: Wed Nov 5 09:55:54 2003 - $Id: movitz.html,v 1.6 2004/03/30 08:35:32 ffjeld Exp $ + $Id: movitz.html,v 1.7 2004/04/07 01:13:41 ffjeld Exp $ --> @@ -20,7 +20,7 @@

Movitz: A Common Lisp OS development platform

-$Id: movitz.html,v 1.6 2004/03/30 08:35:32 ffjeld Exp $ +$Id: movitz.html,v 1.7 2004/04/07 01:13:41 ffjeld Exp $

Files

The latest los0 kernel image and its @@ -157,7 +157,7 @@

  • map-stack-words works similarly for a control stack. A stack is wrapped as a vector specialized to (unsigned-byte -32) in memory, so it will not recognized as pointers by +32) in memory, so it will not be recognized as pointers by e.g. map-heap-words. Hence, this function must be used explicitly over each live control stack in order to capture all pointers in the system. Another reason why stacks are special, is that @@ -179,8 +179,10 @@ to be promoted from the two 256 KB buffers, so you cannot have more than this amount of live, dynamically allocated data. You may trigger the GC process explicitly with (stop-and-copy). Note that -there are still several rough edges remaining this GC implementation, -e.g. it will not behave across any kind of interrupt. +there are still rough edges remaining this GC implementation. +E.g. there is no support for code-vectors migrating yet, although this +will only become an issue when new code-vectors are consed up (i.e. by +incremental compilation of some sort).

    About OS design in Common Lisp

    From ffjeld at common-lisp.net Wed Apr 7 13:55:11 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 07 Apr 2004 09:55:11 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv10915 Modified Files: los0-gc.lisp Log Message: Use interrupt 113 for los0-gc, avoiding any confusion with the old consing regime. Date: Wed Apr 7 09:55:10 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.5 movitz/losp/los0-gc.lisp:1.6 --- movitz/losp/los0-gc.lisp:1.5 Tue Apr 6 20:45:54 2004 +++ movitz/losp/los0-gc.lisp Wed Apr 7 09:55:10 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.5 2004/04/07 00:45:54 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.6 2004/04/07 13:55:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -62,7 +62,8 @@ (:movl (:edx 2) :ecx) (:cmpl #x3fff4 :ecx) (:jge '(:sub-program () - (:int 112) + (:int 113) + ;; This interrupt can be retried. (:jmp 'retry-cons))) (:movl :eax (:edx :ecx 2)) (:movl :ebx (:edx :ecx 6)) @@ -112,7 +113,7 @@ (symbol-function 'new-malloc-clumps)) (setf (symbol-function 'new-malloc-clumps) old-malloc)) - (setf (interrupt-handler 112) 'los0-handle-out-of-memory) + (setf (interrupt-handler 113) 'los0-handle-out-of-memory) (values)) (defun install-old-consing () From ffjeld at common-lisp.net Sun Apr 11 18:53:42 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 11 Apr 2004 14:53:42 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/lib/net/ip6.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/lib/net In directory common-lisp.net:/tmp/cvs-serv16353 Modified Files: ip6.lisp Log Message: Minor edits. Date: Sun Apr 11 14:53:42 2004 Author: ffjeld Index: movitz/losp/lib/net/ip6.lisp diff -u movitz/losp/lib/net/ip6.lisp:1.5 movitz/losp/lib/net/ip6.lisp:1.6 --- movitz/losp/lib/net/ip6.lisp:1.5 Thu Feb 26 06:27:07 2004 +++ movitz/losp/lib/net/ip6.lisp Sun Apr 11 14:53:42 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 14 17:25:31 2001 ;;;; -;;;; $Id: ip6.lisp,v 1.5 2004/02/26 11:27:07 ffjeld Exp $ +;;;; $Id: ip6.lisp,v 1.6 2004/04/11 18:53:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -574,7 +574,6 @@ (let* ((link-local-address (link-local-address-by-mac (mac-address ne2000))) (solicited-node-address (solicited-node-address link-local-address)) (neighbor-cache (make-neighbor-cache))) - ;; (ne2000-multicast-join ne2000 (mac-by-multicast-address solicited-node-address)) (pushnew (mac-by-multicast-address solicited-node-address) (accept-multicast-addresses ne2000) :test #'equal) @@ -594,7 +593,7 @@ (setf (fill-pointer p) 0) (vector-push p packet-pool))) (loop with timings = (make-array 20 :fill-pointer t) - with eval-buffer = (make-array 16384 :element-type 'character :fill-pointer 0) + with eval-buffer = (make-array 4096 :element-type 'character :fill-pointer 0) with eval-prev-seqno = 0 with request-queue = nil with offset = 54 From ffjeld at common-lisp.net Sun Apr 11 18:55:25 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 11 Apr 2004 14:55:25 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv28839 Modified Files: compiler.lisp Log Message: The inlined stack-check in the function prelude should access the limit using the thread-local segment prefix, not the global. Date: Sun Apr 11 14:55:24 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.42 movitz/compiler.lisp:1.43 --- movitz/compiler.lisp:1.42 Tue Apr 6 10:34:45 2004 +++ movitz/compiler.lisp Sun Apr 11 14:55:24 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.42 2004/04/06 14:34:45 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.43 2004/04/11 18:55:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3847,7 +3847,7 @@ (append (when (and do-check-stack-p *compiler-auto-stack-checks-p* (not (without-check-stack-limit-p env))) - `((,*compiler-global-segment-prefix* + `((,*compiler-local-segment-prefix* :bound (:edi ,(global-constant-offset 'stack-bottom)) :esp))) (when use-stack-frame-p `((:pushl :ebp) From ffjeld at common-lisp.net Sun Apr 11 18:56:31 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 11 Apr 2004 14:56:31 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv30760 Modified Files: debugger.lisp Log Message: Improved *stack-frame-setup-patterns* wrt. function prelude stack bounds-check. Date: Sun Apr 11 14:56:31 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.6 movitz/losp/x86-pc/debugger.lisp:1.7 --- movitz/losp/x86-pc/debugger.lisp:1.6 Tue Apr 6 20:34:57 2004 +++ movitz/losp/x86-pc/debugger.lisp Sun Apr 11 14:56:31 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.6 2004/04/07 00:34:57 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.7 2004/04/11 18:56:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -318,7 +318,7 @@ (+ 2 (signed8-index result-position)))))))))))))) (defparameter *stack-frame-setup-patterns* - '(((:* 1 (#x64 #x62 #x67 #xe7)) ; # + '(((:* 1 (#x64 #x62 #x67 (any-offset))) ; # (:* 1 (#x55 #x8b #xec #x56)) ; pushl ebp, movl esp (:* 2 (#x80 #xf9 (cmpargs) (:or (#x72 (label)) From ffjeld at common-lisp.net Sun Apr 11 18:57:06 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 11 Apr 2004 14:57:06 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv32035 Modified Files: los0-gc.lisp Log Message: Minor edit. Date: Sun Apr 11 14:57:06 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.6 movitz/losp/los0-gc.lisp:1.7 --- movitz/losp/los0-gc.lisp:1.6 Wed Apr 7 09:55:10 2004 +++ movitz/losp/los0-gc.lisp Sun Apr 11 14:57:06 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.6 2004/04/07 13:55:10 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.7 2004/04/11 18:57:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -73,7 +73,7 @@ (:ret))) (defun new-malloc-clumps (clumps) - (check-type clumps (integer 0 200)) + (check-type clumps (integer 0 1000)) (with-inline-assembly (:returns :ebx) retry (:compile-form (:result-mode :eax) clumps) From ffjeld at common-lisp.net Tue Apr 13 13:02:33 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 13 Apr 2004 09:02:33 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv31863 Modified Files: primitive-functions.lisp Log Message: Minor comment edits. Date: Tue Apr 13 09:02:33 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.7 movitz/losp/muerte/primitive-functions.lisp:1.8 --- movitz/losp/muerte/primitive-functions.lisp:1.7 Tue Apr 6 20:15:44 2004 +++ movitz/losp/muerte/primitive-functions.lisp Tue Apr 13 09:02:33 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.7 2004/04/07 00:15:44 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.8 2004/04/13 13:02:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -97,7 +97,7 @@ ;;; Catch exit-point: ;;; 12: parent (no parent == #x0) -;;; 8: eip +;;; 8: jumper index (=> eip) ;;; 4: catch tag object/word ;;; 0: ebp/stack-frame @@ -109,7 +109,7 @@ ;;; Basic-restart entry: ;;; 12: parent -;;; 8: eip +;;; 8: jumper index (=> eip) ;;; 4: tag = #:basic-restart-tag ;;; 0: ebp/stack-frame ;;; -4: name From ffjeld at common-lisp.net Tue Apr 13 13:03:10 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 13 Apr 2004 09:03:10 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv32540 Modified Files: compiler.lisp Log Message: Minor fixes to allow a lexical variable to be loaded into the EBP register. Date: Tue Apr 13 09:03:10 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.43 movitz/compiler.lisp:1.44 --- movitz/compiler.lisp:1.43 Sun Apr 11 14:55:24 2004 +++ movitz/compiler.lisp Tue Apr 13 09:03:10 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.43 2004/04/11 18:55:24 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.44 2004/04/13 13:03:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2981,7 +2981,7 @@ (defun single-value-register (mode) (ecase mode ((:eax :single-value :multiple-values :function) :eax) - ((:ebx :ecx :edx :esi :esp) mode))) + ((:ebx :ecx :edx :esi :esp :ebp) mode))) (defun result-mode-register (mode) (case mode @@ -3155,7 +3155,7 @@ result-mode :eax (install-for-single-value binding binding-location :eax t))))) (t (case (result-mode-type result-mode) - ((:single-value :eax :ebx :ecx :edx :esi :esp) + ((:single-value :eax :ebx :ecx :edx :esi :esp :ebp) (install-for-single-value binding binding-location (single-value-register result-mode) nil)) (:push From ffjeld at common-lisp.net Tue Apr 13 13:07:41 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 13 Apr 2004 09:07:41 -0400 Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10399 Modified Files: special-operators-cl.lisp Log Message: Changed the mechanism of dynamic control transfer so as to avoid having instruction-pointers present on the stack. Rather, we keep an index to the jumper-table of the target function. A jumper-table is a table of instruction-pointers pointing somewhere inside the function's code-vector, and is the first n elements of the function-objects constants. The purpose of all this is to reduce the complexity of scavenging the control-stack. Almost all the problems associated with this seems to be rooted in the presence of (potential) untagged instruction-pointers. Date: Tue Apr 13 09:07:41 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.14 movitz/special-operators-cl.lisp:1.15 --- movitz/special-operators-cl.lisp:1.14 Tue Mar 30 16:33:54 2004 +++ movitz/special-operators-cl.lisp Tue Apr 13 09:07:40 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.14 2004/03/30 21:33:54 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.15 2004/04/13 13:07:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -713,7 +713,8 @@ (:jmp (:esi :ecx ,(+ (slot-offset 'movitz-funobj 'constant0) (* 4 label-id)))))))))))) ; transfer control, finally. -(define-special-operator block (&all forward &funobj funobj &form form &env env &result-mode result-mode) +(define-special-operator block (&all forward &funobj funobj &form form &env env + &result-mode result-mode) (destructuring-bind (block-name &body body) (cdr form) (let* ((exit-block-label (gensym (format nil "exit-block-~A-" block-name))) @@ -1140,27 +1141,26 @@ :type '(values &rest t) :code code)))))) -(defun make-compiled-catch-wrapper (tag-form funobj env body-returns body-code &optional exit-point-pusher) +(defun make-compiled-catch-wrapper (tag-form funobj env body-returns body-code) (assert (member body-returns '(:multiple-values :non-local-exit))) (values 4 ; stack-used, must be added to body-code's env. - (with-labels (catch (exit-point-offset exit-point)) - (append (or exit-point-pusher - `((:locally (:pushl (:edi (:edi-offset dynamic-env)))) - (:call (:pc+ 0)) ; push EIP - ,exit-point-offset - (:addl '(:funcall - ',exit-point ',exit-point-offset) (:esp)))) + (with-labels (catch (label-set exit-point)) + (append `((:declare-label-set ,label-set (,exit-point)) + (:locally (:pushl (:edi (:edi-offset dynamic-env)))) ; push dynamic-env + (:pushl ',label-set)) (compiler-call #'compile-form :env env - ;; :with-stack-used 2 + :with-stack-used 2 :funobj funobj :form tag-form :result-mode :push) `((:pushl :ebp) ; push stack frame (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) ; install catch body-code - `((:leal (:esp ,(+ -4 16)) :esp) - (:locally (:popl (:edi (:edi-offset dynamic-env))))) - `(,exit-point))))) + `((:popl :ebp) ; This value is identical to current EBP. + ,exit-point + (:leal (:esp ,(+ -8 16)) :esp) + (:locally (:popl (:edi (:edi-offset dynamic-env))))))))) (define-special-operator unwind-protect (&all all &form form &env env) (destructuring-bind (protected-form &body cleanup-forms) From ffjeld at common-lisp.net Tue Apr 13 13:07:47 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 13 Apr 2004 09:07:47 -0400 Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10494 Modified Files: special-operators.lisp Log Message: Changed the mechanism of dynamic control transfer so as to avoid having instruction-pointers present on the stack. Rather, we keep an index to the jumper-table of the target function. A jumper-table is a table of instruction-pointers pointing somewhere inside the function's code-vector, and is the first n elements of the function-objects constants. The purpose of all this is to reduce the complexity of scavenging the control-stack. Almost all the problems associated with this seems to be rooted in the presence of (potential) untagged instruction-pointers. Date: Tue Apr 13 09:07:47 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.18 movitz/special-operators.lisp:1.19 --- movitz/special-operators.lisp:1.18 Tue Apr 6 20:21:28 2004 +++ movitz/special-operators.lisp Tue Apr 13 09:07:46 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.18 2004/04/07 00:21:28 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.19 2004/04/13 13:07:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1243,33 +1243,41 @@ :forward all) finally (error "No compiler-typecase clause matched compile-time type ~S." keyform-type))))) -(define-special-operator muerte::exact-throw (&all all-throw &form form) +(define-special-operator muerte::exact-throw (&all all-throw &form form &env env &funobj funobj) (destructuring-bind (tag context value-form) (cdr form) - (with-labels (throw (save-tag-variable save-context-var tag-not-found-label)) - (compiler-values () - :returns :non-local-exit - :code (append (compiler-call #'compile-form - :forward all-throw - :result-mode :multiple-values - :form `(muerte.cl:let ((,save-tag-variable ,tag) - (,save-context-var ,context)) - (muerte.cl:multiple-value-prog1 - ,value-form - (muerte::with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :eax) ,save-tag-variable) - (:compile-form (:result-mode :ebx) ,save-context-var) - (:globally (:call (:edi (:edi-offset dynamic-locate-catch-tag)))) - (:jnc '(:sub-program (,tag-not-found-label) (:int 108))) - (:movl :eax :ebp))))) ; save dynamic-slot in EBP - ;; now outside of m-v-prog1's cloak, with final dynamic-slot in ESP.. - ;; ..unwind it and transfer control. - `((:movl :ebp :esp) - (:popl :ebp) - (:movl (:ebp -4) :esi) - (:leal (:esp 8) :esp) ; skip tag and eip - (:locally (:popl (:edi (:edi-offset dynamic-env)))) ; unwind dynamic env - (:jmp (:esp -8)))))))) + (let* ((local-env (make-local-movitz-environment env funobj :type 'let-env)) + (dynamic-slot-binding (movitz-env-add-binding local-env + (make-instance 'located-binding + :name (gensym "dynamic-slot-"))))) + (with-labels (throw (save-tag-var save-context-var)) + (compiler-values () + :returns :non-local-exit + :code (append (compiler-call #'compile-form + :forward all-throw + :result-mode :multiple-values + :form `(muerte.cl:let ((,save-tag-var ,tag) + (,save-context-var ,context)) + (muerte.cl:multiple-value-prog1 + ,value-form + (muerte::with-inline-assembly (:returns :nothing) + (:compile-two-forms (:eax :ebx) ,save-tag-var ,save-context-var) + (:globally (:call (:edi (:edi-offset dynamic-locate-catch-tag)))) + (:jnc '(:sub-program () (:int 108))) + (:store-lexical ,dynamic-slot-binding :eax :type t) + )))) ; save dynamic-slot in EBP + ;; now outside of m-v-prog1's cloak, with final dynamic-slot in ESP.. + ;; ..unwind it and transfer control. + `((:load-lexical ,dynamic-slot-binding :ebp) + (:leave) + (:movl (:ebp -4) :esi) + (:movl (:esp 4) :edx) + ;; (:halt) + (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0)))))))))) + +;;; (:leal (:esp 8) :esp) ; skip tag and eip +;;; (:locally (:popl (:edi (:edi-offset dynamic-env)))) ; unwind dynamic env +;;; (:jmp (:esp -8)))))))) (define-special-operator muerte::with-basic-restart (&all defaults &form form &env env) (destructuring-bind ((name function interactive test format-control @@ -1278,16 +1286,28 @@ (cdr form) (check-type name symbol "a restart name") (let* ((entry-size (+ 10 (* 2 (length format-arguments))))) - (with-labels (basic-restart-catch (exit-point-offset exit-point)) + (with-labels (basic-restart-catch (label-set exit-point)) (compiler-values () :returns :multiple-values - :code (append `((:locally (:pushl (:edi (:edi-offset dynamic-env)))) - (:call (:pc+ 0)) - ,exit-point-offset - (:addl '(:funcall - ',exit-point ',exit-point-offset) (:esp)) - (:globally (:pushl (:edi (:edi-offset restart-tag)))) - (:pushl :ebp) - (:load-constant ,name :push)) +;;; Basic-restart entry: +;;; 12: parent +;;; 8: jumper index (=> eip) +;;; 4: tag = #:basic-restart-tag +;;; 0: ebp/stack-frame +;;; -4: name +;;; -8: function +;;; -12: interactive function +;;; -16: test +;;; -20: format-control +;;; -24: (on-stack) list of format-arguments +;;; -28: cdr +;;; -32: car ... + :code (append `((:locally (:pushl (:edi (:edi-offset dynamic-env)))) ; parent + (:declare-label-set ,label-set (,exit-point)) + (:pushl ',label-set) ; jumper index + (:globally (:pushl (:edi (:edi-offset restart-tag)))) ; tag + (:pushl :ebp) ; ebp + (:load-constant ,name :push)) ; name (compiler-call #'compile-form :defaults defaults :form function @@ -1333,6 +1353,8 @@ :result-mode :multiple-values :with-stack-used entry-size :form body) - `((:leal (:esp ,(+ -4 (* 4 entry-size))) :esp) + `((:leal (:esp ,(+ -12 (* 4 entry-size))) :esp) + ,exit-point + (:leal (:esp ,(+ -8 16)) :esp) (:locally (:popl (:edi (:edi-offset dynamic-env)))) - ,exit-point))))))) + ))))))) From ffjeld at common-lisp.net Tue Apr 13 13:28:26 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 13 Apr 2004 09:28:26 -0400 Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24057 Modified Files: special-operators-cl.lisp Log Message: Added the same change for undwind-protect as the other dynamic control-transfer mechanisms: Use a jumper-table index rather than EIP directly in the on-stack structure. Date: Tue Apr 13 09:28:26 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.15 movitz/special-operators-cl.lisp:1.16 --- movitz/special-operators-cl.lisp:1.15 Tue Apr 13 09:07:40 2004 +++ movitz/special-operators-cl.lisp Tue Apr 13 09:28:26 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.15 2004/04/13 13:07:40 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.16 2004/04/13 13:28:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1168,7 +1168,7 @@ (let ((up-env (make-instance 'unwind-protect-env :uplink env :funobj (movitz-environment-funobj env)))) - (with-labels (unwind-protect (cleanup-entry-offset cleanup-entry)) + (with-labels (unwind-protect (cleanup-label cleanup-entry)) (compiler-call #'compile-form :result-mode :multiple-values :forward all @@ -1178,9 +1178,8 @@ (do-case (t :multiple-values) ;; install up dynamic-env.. (:locally (:pushl (:edi (:edi-offset dynamic-env)))) - (:call (:pc+ 0)) ; EIP - ,cleanup-entry-offset - (:addl '(:funcall - ',cleanup-entry ',cleanup-entry-offset) (:esp)) + (:declare-label-set ,cleanup-label (,cleanup-entry)) + (:pushl ',cleanup-label) ; jumper index (:globally (:pushl (:edi (:edi-offset unwind-protect-tag)))) ; tag (:pushl :ebp) ; stack-frame (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))) ; install up-env @@ -1196,7 +1195,7 @@ ;; execute cleanup-forms (:call '(:sub-program (,cleanup-entry) ; label ,@(compiler-call #'compile-form - :with-stack-used t + :with-stack-used t ; stack distance is _really_ unknown! :defaults all :result-mode :ignore :form `(muerte.cl::progn , at cleanup-forms)) From ffjeld at common-lisp.net Tue Apr 13 13:28:31 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 13 Apr 2004 09:28:31 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24095 Modified Files: primitive-functions.lisp Log Message: Added the same change for undwind-protect as the other dynamic control-transfer mechanisms: Use a jumper-table index rather than EIP directly in the on-stack structure. Date: Tue Apr 13 09:28:31 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.8 movitz/losp/muerte/primitive-functions.lisp:1.9 --- movitz/losp/muerte/primitive-functions.lisp:1.8 Tue Apr 13 09:02:33 2004 +++ movitz/losp/muerte/primitive-functions.lisp Tue Apr 13 09:28:31 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.8 2004/04/13 13:02:33 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.9 2004/04/13 13:28:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -103,7 +103,7 @@ ;;; Unwind-protect entry: ;;; 12: parent -;;; 8: eip +;;; 8: jumper index (=> eip) ;;; 4: tag = #:unwind-protect-tag ;;; 0: ebp/stack-frame @@ -176,7 +176,8 @@ (:locally (:movl :ebx (:edi (:edi-offset dynamic-env)))) (:movl (:eax 0) :ebp) ; install clean-up's stack-frame (but keep our ESP) (:movl (:ebp -4) :esi) ; ..and install clean-up's funobj in ESI - (:call (:eax 8)) + (:movl (:eax 8) :edx) + (:call (:esi :edx #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0))) (:popl :edx) ; restoure our EDX (:popl :ebp) ; restore our EBP (:subl 4 :edx) ; ..slide EDX to next position inside stack-frame. From ffjeld at common-lisp.net Tue Apr 13 14:21:10 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 13 Apr 2004 10:21:10 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16435 Modified Files: packages.lisp Log Message: Moved *read-base* and *package* declarations to variables.lisp. Date: Tue Apr 13 10:21:09 2004 Author: ffjeld Index: movitz/losp/muerte/packages.lisp diff -u movitz/losp/muerte/packages.lisp:1.2 movitz/losp/muerte/packages.lisp:1.3 --- movitz/losp/muerte/packages.lisp:1.2 Mon Jan 19 06:23:47 2004 +++ movitz/losp/muerte/packages.lisp Tue Apr 13 10:21:09 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 30 15:19:43 2001 ;;;; -;;;; $Id: packages.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.3 2004/04/13 14:21:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -19,8 +19,6 @@ (provide :muerte/packages) (in-package muerte) - -(defvar *package*) (defstruct (package (:predicate packagep) From ffjeld at common-lisp.net Tue Apr 13 14:21:14 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 13 Apr 2004 10:21:14 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/read.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16565 Modified Files: read.lisp Log Message: Moved *read-base* and *package* declarations to variables.lisp. Date: Tue Apr 13 10:21:14 2004 Author: ffjeld Index: movitz/losp/muerte/read.lisp diff -u movitz/losp/muerte/read.lisp:1.2 movitz/losp/muerte/read.lisp:1.3 --- movitz/losp/muerte/read.lisp:1.2 Mon Jan 19 06:23:47 2004 +++ movitz/losp/muerte/read.lisp Tue Apr 13 10:21:14 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Oct 17 21:50:42 2001 ;;;; -;;;; $Id: read.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $ +;;;; $Id: read.lisp,v 1.3 2004/04/13 14:21:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -18,8 +18,6 @@ (provide :muerte/read) (in-package muerte) - -(defvar *read-base* 10) (defun substring (string start end) (if (and (zerop start) (= end (length string))) From ffjeld at common-lisp.net Tue Apr 13 14:21:19 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 13 Apr 2004 10:21:19 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/variables.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16607 Modified Files: variables.lisp Log Message: Moved *read-base* and *package* declarations to variables.lisp. Date: Tue Apr 13 10:21:19 2004 Author: ffjeld Index: movitz/losp/muerte/variables.lisp diff -u movitz/losp/muerte/variables.lisp:1.4 movitz/losp/muerte/variables.lisp:1.5 --- movitz/losp/muerte/variables.lisp:1.4 Tue Apr 6 10:31:09 2004 +++ movitz/losp/muerte/variables.lisp Tue Apr 13 10:21:19 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 5 21:53:34 2003 ;;;; -;;;; $Id: variables.lisp,v 1.4 2004/04/06 14:31:09 ffjeld Exp $ +;;;; $Id: variables.lisp,v 1.5 2004/04/13 14:21:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -33,6 +33,9 @@ (defvar + nil) (defvar ++ nil) (defvar +++ nil) + +(defvar *read-base* 10) +(defvar *package*) (defparameter *debugger-hook* nil) (defvar *active-condition-handlers* nil) From ffjeld at common-lisp.net Tue Apr 13 14:21:57 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 13 Apr 2004 10:21:57 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/format.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18083 Modified Files: format.lisp Log Message: Tried to be somewhat more clever about avoiding keyword-parsing in calls to write. Date: Tue Apr 13 10:21:57 2004 Author: ffjeld Index: movitz/losp/muerte/format.lisp diff -u movitz/losp/muerte/format.lisp:1.3 movitz/losp/muerte/format.lisp:1.4 --- movitz/losp/muerte/format.lisp:1.3 Wed Mar 24 14:30:15 2004 +++ movitz/losp/muerte/format.lisp Tue Apr 13 10:21:57 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Mar 23 01:18:36 2002 ;;;; -;;;; $Id: format.lisp,v 1.3 2004/03/24 19:30:15 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.4 2004/04/13 14:21:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -51,12 +51,13 @@ (padchar (or (second prefix-parameters) #\space)) (commachar (or (third prefix-parameters) #\,)) (comma-interval (or (fourth prefix-parameters) 3))) - (write-integer x *standard-output* :radix nil :base base - :mincol mincol :padchar padchar - :comma-interval (and colon-p comma-interval) - :comma-char commachar - :sign-always at-sign-p)) - (write x :escape nil :radix nil :base base :readably nil))) + (write-integer x *standard-output* base nil + mincol padchar at-sign-p commachar (and colon-p comma-interval))) + (let ((*print-escape* nil) + (*print-radix* nil) + (*print-base* base) + (*print-readably* nil)) + (write x)))) (defun find-directive (string i directive &optional recursive-skip-start (recursive-skip-end directive)) From ffjeld at common-lisp.net Tue Apr 13 14:22:02 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 13 Apr 2004 10:22:02 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18310 Modified Files: print.lisp Log Message: Tried to be somewhat more clever about avoiding keyword-parsing in calls to write. Date: Tue Apr 13 10:22:02 2004 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.5 movitz/losp/muerte/print.lisp:1.6 --- movitz/losp/muerte/print.lisp:1.5 Tue Apr 6 10:29:33 2004 +++ movitz/losp/muerte/print.lisp Tue Apr 13 10:22:02 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.5 2004/04/06 14:29:33 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.6 2004/04/13 14:22:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -100,9 +100,9 @@ (write-char comma-char stream)) nil) -(defun write-integer (x stream &key (base *print-base*) (radix *print-radix*) - mincol (padchar #\space) - (sign-always nil) (comma-char #\,) (comma-interval nil)) +(defun write-integer (x stream base radix + &optional mincol (padchar #\space) + (sign-always nil) (comma-char #\,) (comma-interval nil)) (when radix (case base (10) ; put a #\. at the end. @@ -124,7 +124,7 @@ (8 #.(cl:format cl:nil "~O" movitz::+movitz-most-negative-fixnum+)) (10 #.(cl:format cl:nil "~D" movitz::+movitz-most-negative-fixnum+)) (16 #.(cl:format cl:nil "~X" movitz::+movitz-most-negative-fixnum+)) - (t "minus-hack")) + (t (break "minus-hack!?"))) stream)))) (sign-always (values #\+ x)) @@ -160,170 +160,197 @@ (pretty *print-pretty*) (radix *print-radix*) ((:readably *print-readably*) *print-readably*) right-margin) - (declare (dynamic-extent key-args) - (special *read-base* *package*) - (ignore case circle pprint-dispatch miser-width right-margin lines)) - (cond - ((and *print-safely* (not safe-recursive-call)) - (handler-case (apply #'write object :safe-recursive-call t key-args) - (t (condition) - (write-string "#" stream)))) - ((and (not pretty) - (not *never-use-print-object*)) - (print-object object stream)) - (t (let ((do-escape-p (or *print-escape* *print-readably*)) - (stream (output-stream-designator stream)) - (*print-level* (minus-if level 1))) - (typecase object - (character - (if (not do-escape-p) - (write-char object stream) - (progn - (write-string "#\\" stream) - (let ((name (char-name object))) - (if name - (write-string name stream) - (write-char object stream)))))) - (null - (write-string (symbol-name nil) stream)) - ((or cons tag5) - (cond - ((and *print-level* (minusp *print-level*)) - (write-char #\# stream)) - ((and (eq 'quote (car object)) - (not (cddr object))) - (write-char #\' stream) - (write (cadr object) :stream stream)) - (t (labels ((write-cons (c stream length) - (cond - ((and length (= 0 length)) - (write-string "...)")) - (t (write (car c) :stream stream) - (typecase (cdr c) - (null - (write-char #\) stream)) - (cons - (write-char #\space stream) - (write-cons (cdr c) stream (minus-if length 1))) - (t - (write-string " . " stream) - (write (cdr c) :stream stream) - (write-char #\) stream))))))) - (write-char #\( stream) - (write-cons object stream length))))) - (integer - (write-integer object stream :base base :radix radix)) - (string - (if do-escape-p - (stream-write-escaped-string stream object #\") - (write-string object stream))) - (symbol ; 22.1.3.3 Printing Symbols - (flet ((write-symbol-name (symbol stream) - (let ((name (symbol-name symbol))) - (if (and (plusp (length name)) - (every (lambda (c) - (or (upper-case-p c) - (member c '(#\- #\% #\$ #\* #\@ #\. #\& #\< #\> #\=)) - (digit-char-p c))) - name) - (not (every (lambda (c) - (or (digit-char-p c *read-base*) - (member c '(#\.)))) - name))) - (write-string name stream) - (stream-write-escaped-string stream name #\|))))) - (cond - ((not do-escape-p) - (write-symbol-name object stream)) - ((eq (symbol-package object) (find-package "KEYWORD")) - (write-string ":" stream) - (write-symbol-name object stream)) - ((or (eq (symbol-package object) *package*) - (eq (find-symbol (string object)) - object)) - (write-symbol-name object stream)) - ((symbol-package object) - (let ((package (symbol-package object))) - (write-string (package-name package) stream) - (write-string (if (gethash (symbol-name object) - (package-object-external-symbols package)) - ":" "::") - stream) - (write-symbol-name object stream))) - ((not (symbol-package object)) - (when *print-gensym* - (write-string "#:" stream)) - (write-symbol-name object stream)) - (t (error "Huh?"))))) - (vector - (cond - ((and *print-level* (minusp *print-level*)) - (write-char #\# stream)) - ((or array *print-readably*) - (write-string "#(" stream) - (cond - ((and length (< length (length object))) - (dotimes (i length) - (unless (= 0 i) - (write-char #\space stream)) - (write (aref object i))) - (write-string " ...)" stream)) - (t (dotimes (i (length object)) - (unless (= 0 i) - (write-char #\space stream)) - (write (aref object i) :stream stream)) - (write-char #\) stream)))) - (t (print-unreadable-object (object stream :identity t) - (princ (type-of object) stream))))) - (standard-gf-instance - (print-unreadable-object (object stream) - (format stream "gf ~S" (funobj-name object)))) - (compiled-function - (print-unreadable-object (object stream) - (format stream "function ~S" (funobj-name object)))) - (hash-table - (print-unreadable-object (object stream :identity nil :type nil) - (format stream "~S hash-table with ~D entries" - (let ((test (hash-table-test object))) - (if (typep test 'compiled-function) - (funobj-name test) - test)) - (hash-table-count object)))) - (package - (if (package-name object) - (print-unreadable-object (object stream :identity nil :type nil) - (format stream "Package ~A with ~D+~D symbols" - (package-name object) - (hash-table-count (package-object-external-symbols object)) - (hash-table-count (package-object-internal-symbols object)))) - (print-unreadable-object (object stream :identity t :type t)))) - (t (if (not *never-use-print-object*) - (print-object object stream) - (print-unreadable-object (object stream :identity t) - (cond - ((typep object 'std-instance) - (write-string "[std-instance]" stream) - (write (standard-instance-access (std-instance-class object) 0) :stream stream)) - ((typep object 'standard-gf-instance) - (write-string "[std-gf-instance]" stream)) - (t (princ (type-of object) stream)))))))))) - object) + (numargs-case + (t (object &key safe-recursive-call + ;; lines miser-width pprint-dispatch right-margin case circle + ((:stream *standard-output*) *standard-output*) + ((:array *print-array*) *print-array*) + ((:base *print-base*) *print-base*) + ((:escape *print-escape*) *print-escape*) + ((:gensym *print-gensym*) *print-gensym*) + ((:length *print-length*) *print-length*) + ((:level *print-level*) *print-level*) + ((:pretty *print-pretty*) *print-pretty*) + ((:radix *print-radix*) *print-radix*) + ((:readably *print-readably*) *print-readably*)) + (cond + ((and *print-safely* (not safe-recursive-call)) + (handler-case (write object :safe-recursive-call t) + (t (condition) + (write-string "#")))) + (t (write object)))) + (1 (object) + (let ((stream (output-stream-designator *standard-output*))) + (cond + ((and (not *print-pretty*) + (not *never-use-print-object*)) + (print-object object stream)) + (t (let ((do-escape-p (or *print-escape* *print-readably*)) + (*print-level* (minus-if *print-level* 1))) + (typecase object + (character + (if (not do-escape-p) + (write-char object stream) + (progn + (write-string "#\\" stream) + (let ((name (char-name object))) + (if name + (write-string name stream) + (write-char object stream)))))) + (null + (write-string (symbol-name nil) stream)) + ((or cons tag5) + (let ((level *print-level*) + (length *print-length*)) + (cond + ((and level (minusp level)) + (write-char #\# stream)) + ((and (eq 'quote (car object)) + (not (cddr object))) + (write-char #\' stream) + (write (cadr object))) + (t (labels ((write-cons (c stream length) + (cond + ((and length (= 0 length)) + (write-string "...)")) + (t (write (car c)) + (typecase (cdr c) + (null + (write-char #\) stream)) + (cons + (write-char #\space stream) + (write-cons (cdr c) stream (minus-if length 1))) + (t + (write-string " . " stream) + (write (cdr c)) + (write-char #\) stream))))))) + (write-char #\( stream) + (write-cons object stream length)))))) + (integer + (write-integer object stream *print-base* *print-radix*)) + (string + (if do-escape-p + (stream-write-escaped-string stream object #\") + (write-string object stream))) + (symbol ; 22.1.3.3 Printing Symbols + (flet ((write-symbol-name (symbol stream) + (let ((name (symbol-name symbol))) + (if (and (plusp (length name)) + (every (lambda (c) + (or (upper-case-p c) + (member c '(#\- #\% #\$ #\* #\@ #\. #\& #\< #\> #\=)) + (digit-char-p c))) + name) + (not (every (lambda (c) + (or (digit-char-p c *read-base*) + (member c '(#\.)))) + name))) + (write-string name stream) + (stream-write-escaped-string stream name #\|))))) + (cond + ((not do-escape-p) + (write-symbol-name object stream)) + ((eq (symbol-package object) (find-package "KEYWORD")) + (write-string ":" stream) + (write-symbol-name object stream)) + ((or (eq (symbol-package object) *package*) + (eq (find-symbol (string object)) + object)) + (write-symbol-name object stream)) + ((symbol-package object) + (let ((package (symbol-package object))) + (write-string (package-name package) stream) + (write-string (if (gethash (symbol-name object) + (package-object-external-symbols package)) + ":" "::") + stream) + (write-symbol-name object stream))) + ((not (symbol-package object)) + (when *print-gensym* + (write-string "#:" stream)) + (write-symbol-name object stream)) + (t (error "Huh?"))))) + (vector + (let ((level *print-level*) + (length *print-length*)) + (cond + ((and level (minusp level)) + (write-char #\# stream)) + ((or *print-array* *print-readably*) + (write-string "#(" stream) + (cond + ((and length (< length (length object))) + (dotimes (i length) + (unless (= 0 i) + (write-char #\space stream)) + (write (aref object i))) + (write-string " ...)" stream)) + (t (dotimes (i (length object)) + (unless (= 0 i) + (write-char #\space stream)) + (write (aref object i))) + (write-char #\) stream)))) + (t (print-unreadable-object (object stream :identity t) + (princ (type-of object) stream)))))) + (standard-gf-instance + (print-unreadable-object (object stream) + (format stream "gf ~S" (funobj-name object)))) + (compiled-function + (print-unreadable-object (object stream) + (format stream "function ~S" (funobj-name object)))) + (hash-table + (print-unreadable-object (object stream :identity nil :type nil) + (format stream "~S hash-table with ~D entries" + (let ((test (hash-table-test object))) + (if (typep test 'compiled-function) + (funobj-name test) + test)) + (hash-table-count object)))) + (package + (if (package-name object) + (print-unreadable-object (object stream :identity nil :type nil) + (format stream "Package ~A with ~D+~D symbols" + (package-name object) + (hash-table-count (package-object-external-symbols object)) + (hash-table-count (package-object-internal-symbols object)))) + (print-unreadable-object (object stream :identity t :type t)))) + (t (if (not *never-use-print-object*) + (print-object object stream) + (print-unreadable-object (object stream :identity t) + (cond + ((typep object 'std-instance) + (write-string "[std-instance]" stream) + (write (standard-instance-access (std-instance-class object) 0))) + ((typep object 'standard-gf-instance) + (write-string "[std-gf-instance]" stream)) + (t (princ (type-of object) stream))))))))))) + object))) (defun prin1 (object &optional stream) - (write object :stream stream :escape t)) + (let ((*standard-output* (output-stream-designator stream)) + (*print-escape* t)) + (write object))) (defun princ (object &optional stream) - (write object :stream stream :escape nil :readably nil)) + (let ((*standard-output* (output-stream-designator stream)) + (*print-escape* nil) + (*print-readably* nil)) + (write object))) (defun print (object &optional stream) - (terpri stream) - (write object :stream stream :escape t) - (write-char #\Space stream) - object) + (let ((*standard-output* (output-stream-designator stream)) + (*print-escape* t)) + (write-char #\newline) + (write object) + (write-char #\Space) + object)) (defun pprint (object &optional stream) - (write object :stream stream :escape t :pretty t) - (values)) + (let ((*standard-output* (output-stream-designator stream)) + (*print-escape* t) + (*print-pretty* t)) + (write object) + (values))) (defun terpri (&optional stream) (write-char #\newline stream) From ffjeld at common-lisp.net Tue Apr 13 15:15:55 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 13 Apr 2004 11:15:55 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26853 Modified Files: print.lisp Log Message: Extracted internal-write from write. *print-safely* should work again. Date: Tue Apr 13 11:15:55 2004 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.6 movitz/losp/muerte/print.lisp:1.7 --- movitz/losp/muerte/print.lisp:1.6 Tue Apr 13 10:22:02 2004 +++ movitz/losp/muerte/print.lisp Tue Apr 13 11:15:55 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.6 2004/04/13 14:22:02 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.7 2004/04/13 15:15:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -161,9 +161,8 @@ ((:readably *print-readably*) *print-readably*) right-margin) (numargs-case - (t (object &key safe-recursive-call + (t (object &key stream ;; lines miser-width pprint-dispatch right-margin case circle - ((:stream *standard-output*) *standard-output*) ((:array *print-array*) *print-array*) ((:base *print-base*) *print-base*) ((:escape *print-escape*) *print-escape*) @@ -173,158 +172,161 @@ ((:pretty *print-pretty*) *print-pretty*) ((:radix *print-radix*) *print-radix*) ((:readably *print-readably*) *print-readably*)) - (cond - ((and *print-safely* (not safe-recursive-call)) - (handler-case (write object :safe-recursive-call t) - (t (condition) - (write-string "#")))) - (t (write object)))) + (let ((*standard-output* (output-stream-designator stream))) + (write object))) (1 (object) - (let ((stream (output-stream-designator *standard-output*))) - (cond - ((and (not *print-pretty*) - (not *never-use-print-object*)) - (print-object object stream)) - (t (let ((do-escape-p (or *print-escape* *print-readably*)) - (*print-level* (minus-if *print-level* 1))) - (typecase object - (character - (if (not do-escape-p) - (write-char object stream) - (progn - (write-string "#\\" stream) - (let ((name (char-name object))) - (if name - (write-string name stream) - (write-char object stream)))))) - (null - (write-string (symbol-name nil) stream)) - ((or cons tag5) - (let ((level *print-level*) - (length *print-length*)) - (cond - ((and level (minusp level)) - (write-char #\# stream)) - ((and (eq 'quote (car object)) - (not (cddr object))) - (write-char #\' stream) - (write (cadr object))) - (t (labels ((write-cons (c stream length) - (cond - ((and length (= 0 length)) - (write-string "...)")) - (t (write (car c)) - (typecase (cdr c) - (null - (write-char #\) stream)) - (cons - (write-char #\space stream) - (write-cons (cdr c) stream (minus-if length 1))) - (t - (write-string " . " stream) - (write (cdr c)) - (write-char #\) stream))))))) - (write-char #\( stream) - (write-cons object stream length)))))) - (integer - (write-integer object stream *print-base* *print-radix*)) - (string - (if do-escape-p - (stream-write-escaped-string stream object #\") - (write-string object stream))) - (symbol ; 22.1.3.3 Printing Symbols - (flet ((write-symbol-name (symbol stream) - (let ((name (symbol-name symbol))) - (if (and (plusp (length name)) - (every (lambda (c) - (or (upper-case-p c) - (member c '(#\- #\% #\$ #\* #\@ #\. #\& #\< #\> #\=)) - (digit-char-p c))) - name) - (not (every (lambda (c) - (or (digit-char-p c *read-base*) - (member c '(#\.)))) - name))) - (write-string name stream) - (stream-write-escaped-string stream name #\|))))) - (cond - ((not do-escape-p) - (write-symbol-name object stream)) - ((eq (symbol-package object) (find-package "KEYWORD")) - (write-string ":" stream) - (write-symbol-name object stream)) - ((or (eq (symbol-package object) *package*) - (eq (find-symbol (string object)) - object)) - (write-symbol-name object stream)) - ((symbol-package object) - (let ((package (symbol-package object))) - (write-string (package-name package) stream) - (write-string (if (gethash (symbol-name object) - (package-object-external-symbols package)) - ":" "::") - stream) - (write-symbol-name object stream))) - ((not (symbol-package object)) - (when *print-gensym* - (write-string "#:" stream)) - (write-symbol-name object stream)) - (t (error "Huh?"))))) - (vector - (let ((level *print-level*) - (length *print-length*)) - (cond - ((and level (minusp level)) - (write-char #\# stream)) - ((or *print-array* *print-readably*) - (write-string "#(" stream) - (cond - ((and length (< length (length object))) - (dotimes (i length) - (unless (= 0 i) - (write-char #\space stream)) - (write (aref object i))) - (write-string " ...)" stream)) - (t (dotimes (i (length object)) - (unless (= 0 i) - (write-char #\space stream)) - (write (aref object i))) - (write-char #\) stream)))) - (t (print-unreadable-object (object stream :identity t) - (princ (type-of object) stream)))))) - (standard-gf-instance - (print-unreadable-object (object stream) - (format stream "gf ~S" (funobj-name object)))) - (compiled-function - (print-unreadable-object (object stream) - (format stream "function ~S" (funobj-name object)))) - (hash-table + (if (not *print-safely*) + (internal-write object) + (handler-case (internal-write object) + (serious-condition (c) + (format t "#" object c))))))) + +(defun internal-write (object) + (let ((stream *standard-output*)) + (cond + ((and (not *print-pretty*) + (not *never-use-print-object*)) + (print-object object stream)) + (t (let ((do-escape-p (or *print-escape* *print-readably*)) + (*print-level* (minus-if *print-level* 1))) + (typecase object + (character + (if (not do-escape-p) + (write-char object stream) + (progn + (write-string "#\\" stream) + (let ((name (char-name object))) + (if name + (write-string name stream) + (write-char object stream)))))) + (null + (write-string (symbol-name nil) stream)) + ((or cons tag5) + (let ((level *print-level*) + (length *print-length*)) + (cond + ((and level (minusp level)) + (write-char #\# stream)) + ((and (eq 'quote (car object)) + (not (cddr object))) + (write-char #\' stream) + (write (cadr object))) + (t (labels ((write-cons (c stream length) + (cond + ((and length (= 0 length)) + (write-string "...)")) + (t (write (car c)) + (typecase (cdr c) + (null + (write-char #\) stream)) + (cons + (write-char #\space stream) + (write-cons (cdr c) stream (minus-if length 1))) + (t + (write-string " . " stream) + (write (cdr c)) + (write-char #\) stream))))))) + (write-char #\( stream) + (write-cons object stream length)))))) + (integer + (write-integer object stream *print-base* *print-radix*)) + (string + (if do-escape-p + (stream-write-escaped-string stream object #\") + (write-string object stream))) + (symbol ; 22.1.3.3 Printing Symbols + (flet ((write-symbol-name (symbol stream) + (let ((name (symbol-name symbol))) + (if (and (plusp (length name)) + (every (lambda (c) + (or (upper-case-p c) + (member c '(#\- #\% #\$ #\* #\@ #\. #\& #\< #\> #\=)) + (digit-char-p c))) + name) + (not (every (lambda (c) + (or (digit-char-p c *read-base*) + (member c '(#\.)))) + name))) + (write-string name stream) + (stream-write-escaped-string stream name #\|))))) + (cond + ((not do-escape-p) + (write-symbol-name object stream)) + ((eq (symbol-package object) (find-package "KEYWORD")) + (write-string ":" stream) + (write-symbol-name object stream)) + ((or (eq (symbol-package object) *package*) + (eq (find-symbol (string object)) + object)) + (write-symbol-name object stream)) + ((symbol-package object) + (let ((package (symbol-package object))) + (write-string (package-name package) stream) + (write-string (if (gethash (symbol-name object) + (package-object-external-symbols package)) + ":" "::") + stream) + (write-symbol-name object stream))) + ((not (symbol-package object)) + (when *print-gensym* + (write-string "#:" stream)) + (write-symbol-name object stream)) + (t (error "Huh?"))))) + (vector + (let ((level *print-level*) + (length *print-length*)) + (cond + ((and level (minusp level)) + (write-char #\# stream)) + ((or *print-array* *print-readably*) + (write-string "#(" stream) + (cond + ((and length (< length (length object))) + (dotimes (i length) + (unless (= 0 i) + (write-char #\space stream)) + (write (aref object i))) + (write-string " ...)" stream)) + (t (dotimes (i (length object)) + (unless (= 0 i) + (write-char #\space stream)) + (write (aref object i))) + (write-char #\) stream)))) + (t (print-unreadable-object (object stream :identity t) + (princ (type-of object) stream)))))) + (standard-gf-instance + (print-unreadable-object (object stream) + (format stream "gf ~S" (funobj-name object)))) + (compiled-function + (print-unreadable-object (object stream) + (format stream "function ~S" (funobj-name object)))) + (hash-table + (print-unreadable-object (object stream :identity nil :type nil) + (format stream "~S hash-table with ~D entries" + (let ((test (hash-table-test object))) + (if (typep test 'compiled-function) + (funobj-name test) + test)) + (hash-table-count object)))) + (package + (if (package-name object) (print-unreadable-object (object stream :identity nil :type nil) - (format stream "~S hash-table with ~D entries" - (let ((test (hash-table-test object))) - (if (typep test 'compiled-function) - (funobj-name test) - test)) - (hash-table-count object)))) - (package - (if (package-name object) - (print-unreadable-object (object stream :identity nil :type nil) - (format stream "Package ~A with ~D+~D symbols" - (package-name object) - (hash-table-count (package-object-external-symbols object)) - (hash-table-count (package-object-internal-symbols object)))) - (print-unreadable-object (object stream :identity t :type t)))) - (t (if (not *never-use-print-object*) - (print-object object stream) - (print-unreadable-object (object stream :identity t) - (cond - ((typep object 'std-instance) - (write-string "[std-instance]" stream) - (write (standard-instance-access (std-instance-class object) 0))) - ((typep object 'standard-gf-instance) - (write-string "[std-gf-instance]" stream)) - (t (princ (type-of object) stream))))))))))) - object))) + (format stream "Package ~A with ~D+~D symbols" + (package-name object) + (hash-table-count (package-object-external-symbols object)) + (hash-table-count (package-object-internal-symbols object)))) + (print-unreadable-object (object stream :identity t :type t)))) + (t (if (not *never-use-print-object*) + (print-object object stream) + (print-unreadable-object (object stream :identity t) + (cond + ((typep object 'std-instance) + (write-string "[std-instance]" stream) + (write (standard-instance-access (std-instance-class object) 0))) + ((typep object 'standard-gf-instance) + (write-string "[std-gf-instance]" stream)) + (t (princ (type-of object) stream))))))))))) + object) (defun prin1 (object &optional stream) (let ((*standard-output* (output-stream-designator stream)) From ffjeld at common-lisp.net Tue Apr 13 16:30:36 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 13 Apr 2004 12:30:36 -0400 Subject: [movitz-cvs] CVS update: movitz/eval.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv20526 Modified Files: eval.lisp Log Message: movitz-constantp should know that a string is indeed constant (self-evaluating, that is) Date: Tue Apr 13 12:30:36 2004 Author: ffjeld Index: movitz/eval.lisp diff -u movitz/eval.lisp:1.4 movitz/eval.lisp:1.5 --- movitz/eval.lisp:1.4 Wed Mar 31 11:31:44 2004 +++ movitz/eval.lisp Tue Apr 13 12:30:36 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 2 17:45:05 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: eval.lisp,v 1.4 2004/03/31 16:31:44 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.5 2004/04/13 16:30:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -63,6 +63,7 @@ (number t) (keyword t) (character t) + (string t) (symbol (or (movitz-env-get form 'constantp nil environment) (typep (movitz-binding form environment) 'constant-object-binding))) (cons (case (car form) From ffjeld at common-lisp.net Tue Apr 13 16:40:54 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 13 Apr 2004 12:40:54 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11686 Modified Files: basic-macros.lisp Log Message: Added a compiler-macro for defparameter. This should reduce the number of file-toplevels that needs to be executed at boot-time just to initialize some variables to constant values. Date: Tue Apr 13 12:40:53 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.6 movitz/losp/muerte/basic-macros.lisp:1.7 --- movitz/losp/muerte/basic-macros.lisp:1.6 Tue Apr 6 09:39:47 2004 +++ movitz/losp/muerte/basic-macros.lisp Tue Apr 13 12:40:53 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.6 2004/04/06 13:39:47 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.7 2004/04/13 16:40:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -119,8 +119,20 @@ ;; (muerte::compile-time-setq ,name ,initial-value) (setq ,name ,initial-value))) -(defmacro defvar (name &optional value documentation) - `(defparameter ,name ,value ,documentation)) +(define-compiler-macro defparameter (&whole form name initial-value + &optional docstring &environment env) + (declare (ignore docstring)) + (if (not (movitz:movitz-constantp initial-value env)) + form + (let ((mname (translate-program name :cl :muerte.cl))) + (setf (movitz::movitz-symbol-value (movitz:movitz-read mname)) + (movitz:movitz-eval initial-value env)) + `(declaim (special ,name))))) + +(defmacro defvar (name &optional (value nil valuep) documentation) + (if (not valuep) + `(declaim (special ,name)) + `(defparameter ,name ,value ,documentation))) (defmacro define-compile-time-variable (name value) `(progn From ffjeld at common-lisp.net Tue Apr 13 16:55:09 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 13 Apr 2004 12:55:09 -0400 Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11619 Modified Files: special-operators-cl.lisp Log Message: For exception 98, used to signal an undefined function, use EDX rather than ECX to carry the offending function name, since ECX isn't a GC root. Date: Tue Apr 13 12:55:09 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.16 movitz/special-operators-cl.lisp:1.17 --- movitz/special-operators-cl.lisp:1.16 Tue Apr 13 09:28:26 2004 +++ movitz/special-operators-cl.lisp Tue Apr 13 12:55:08 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.16 2004/04/13 13:28:26 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.17 2004/04/13 16:55:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -895,7 +895,7 @@ (:globally (:cmpl (:edi (:edi-offset unbound-function)) ,register)) (:je '(:sub-program () - (:load-constant ,movitz-name :ecx) + (:load-constant ,movitz-name :edx) (:int 98)))) :modifies nil :functional-p t From ffjeld at common-lisp.net Tue Apr 13 16:55:17 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 13 Apr 2004 12:55:17 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12837 Modified Files: interrupt.lisp Log Message: For exception 98, used to signal an undefined function, use EDX rather than ECX to carry the offending function name, since ECX isn't a GC root. Date: Tue Apr 13 12:55:17 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.2 movitz/losp/muerte/interrupt.lisp:1.3 --- movitz/losp/muerte/interrupt.lisp:1.2 Tue Apr 6 20:34:47 2004 +++ movitz/losp/muerte/interrupt.lisp Tue Apr 13 12:55:17 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.2 2004/04/07 00:34:47 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.3 2004/04/13 16:55:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -215,7 +215,7 @@ (70 (error "[EIP=~@Z] Index ~@Z out of bounds ~@Z for ~S." $eip $ecx $ebx (@ $eax))) (98 - (let ((name (@ $ecx))) + (let ((name (@ $edx))) (when (symbolp name) (error 'undefined-function :name name)))) (99 From ffjeld at common-lisp.net Wed Apr 14 12:11:33 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 08:11:33 -0400 Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29310 Modified Files: procfs-image.lisp Log Message: Reflect the new interrupt-frame layout in backtrace. Date: Wed Apr 14 08:11:32 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.4 movitz/procfs-image.lisp:1.5 --- movitz/procfs-image.lisp:1.4 Tue Apr 6 10:35:36 2004 +++ movitz/procfs-image.lisp Wed Apr 14 08:11:32 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.4 2004/04/06 14:35:36 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.5 2004/04/14 12:11:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -164,6 +164,10 @@ (when (zerop (ldb (byte 2 0) stack-frame)) (get-word (- stack-frame -4)))) +(defun interrupt-frame-index (name) + (- 5 (position name + '(nil :eflags :eip :error-code :exception :ebp nil + :ecx :eax :edx :ebx :esi :edi)))) (defun backtrace () (format t "~&Backtracing from EIP = #x~X: " (image-register32 *image* :eip)) @@ -182,14 +186,13 @@ (return-from backtrace nil)) (write-string "?") (let* ((r (stack-frame-return-address stack-frame)) - (eax (get-word (+ stack-frame 28 8))) - (ecx (get-word (+ stack-frame 24 8))) - (edi (get-word (+ stack-frame 0 8))) - (eip (get-word (+ stack-frame 40 8))) - (exception (get-word (+ stack-frame 32 8))) - (return (get-word (+ stack-frame 52 8)))) - (when r (format t " (ret #x~X {EAX: #x~X, ECX: #x~X, EDI: #x~X, EIP: #x~X, exception ~D, ret: #x~X})" - r eax ecx edi eip exception return)))) + (eax (get-word (+ (* 4 (interrupt-frame-index :eax)) stack-frame))) + (ecx (get-word (+ (* 4 (interrupt-frame-index :ecx)) stack-frame))) + (edi (get-word (+ (* 4 (interrupt-frame-index :edi)) stack-frame))) + (eip (get-word (+ (* 4 (interrupt-frame-index :eip)) stack-frame))) + (exception (get-word (+ (* 4 (interrupt-frame-index :exception)) stack-frame)))) + (when r (format t " (ret #x~X {EAX: #x~X, ECX: #x~X, EDI: #x~X, EIP: #x~X, exception ~D})" + r eax ecx edi eip exception)))) (movitz-symbol (let ((name (movitz-print movitz-name))) (write-string (symbol-name name)) From ffjeld at common-lisp.net Wed Apr 14 12:21:54 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 08:21:54 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18667 Modified Files: basic-macros.lisp Log Message: Removed bogus macro without-gc. Date: Wed Apr 14 08:21:53 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.7 movitz/losp/muerte/basic-macros.lisp:1.8 --- movitz/losp/muerte/basic-macros.lisp:1.7 Tue Apr 13 12:40:53 2004 +++ movitz/losp/muerte/basic-macros.lisp Wed Apr 14 08:21:53 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.7 2004/04/13 16:40:53 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.8 2004/04/14 12:21:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -885,14 +885,6 @@ (:andl #x7 :ecx) (:call (:edi (:ecx 4) ,(movitz::global-constant-offset 'fast-class-of))))) -(define-compiler-macro without-gc (&body body) - `(multiple-value-prog1 - (progn (with-inline-assembly (:returns :nothing) (:std)) - , at body) - (with-inline-assembly (:returns :nothing) (:cld)))) - -;;; - (defmacro std-instance-reader (slot instance-form) (let ((slot (intern (symbol-name slot) :movitz))) `(with-inline-assembly-case () @@ -1010,7 +1002,6 @@ (let ((infinite-loop-label (make-symbol "infinite-loop"))) `(with-inline-assembly (:returns :nothing) ,infinite-loop-label - (:movl #xabbabeef :eax) (:halt) (:jmp ',infinite-loop-label)))) From ffjeld at common-lisp.net Wed Apr 14 12:25:28 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 08:25:28 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29291 Modified Files: functions.lisp Log Message: Slight rewrite of some funobj accessors. This still needs work, though. Date: Wed Apr 14 08:25:28 2004 Author: ffjeld Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.7 movitz/losp/muerte/functions.lisp:1.8 --- movitz/losp/muerte/functions.lisp:1.7 Sun Mar 28 12:31:41 2004 +++ movitz/losp/muerte/functions.lisp Wed Apr 14 08:25:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.7 2004/03/28 17:31:41 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.8 2004/04/14 12:25:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -84,14 +84,13 @@ (defun funobj-code-vector (funobj) (check-type funobj compiled-function) - (%word-offset (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :lisp) - -2)) + (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :code-vector)) (defun (setf funobj-code-vector) (code-vector funobj) (check-type funobj compiled-function) (check-type code-vector vector-u8) - (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :lisp) - (%word-offset code-vector 2))) + (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :code-vector) + code-vector)) (defun funobj-code-vector%1op (funobj) "This slot is not a lisp value, it is a direct address to code entry point. In practice it is either @@ -274,16 +273,18 @@ "Index ~D out of range, ~S has ~D constants." index funobj (funobj-num-constants funobj)) (if (>= index (funobj-num-jumpers funobj)) (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:constant0) index :lisp) - (without-gc - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :untagged-fixnum-ecx) funobj index) - (:movl (:eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) - :ebx) - (:negl :ebx) - (:addl ((:ecx 4) :eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:constant0)) - :ebx) - (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :eax) - (:xorl :ebx :ebx))))) + ;; For a jumper, return its offset relative to the code-vector. + ;; This is tricky wrt. to potential GC interrupts, because we're doing + ;; pointer arithmetics. + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) funobj index) + (:movl #.movitz:+code-vector-transient-word+ :ebx) + (:addl (:eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) + :ebx) ; code-vector (word) into ebx + (:subl (:eax :ecx #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:constant0)) + :ebx) + (:negl :ebx) + (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :eax)))) (defun (setf funobj-constant-ref) (value funobj index) (check-type funobj compiled-function) @@ -297,10 +298,10 @@ (assert (below value (length (funobj-code-vector funobj))) (value) "The jumper value ~D is invalid because the code-vector's size is ~D." value (length (funobj-code-vector funobj))) - (without-gc + (progn ;; without-gc (with-inline-assembly (:returns :nothing) - (:compile-two-forms (:eax :untagged-fixnum-ecx) funobj index) - (:leal ((:ecx 4) :eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:constant0)) + (:compile-two-forms (:eax :ecx) funobj index) + (:leal (:ecx :eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:constant0)) :ebx) ; dest. address into ebx. (:compile-form (:result-mode :untagged-fixnum-ecx) value) (:addl (:eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) From ffjeld at common-lisp.net Wed Apr 14 12:31:10 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 08:31:10 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11289 Modified Files: memref.lisp Log Message: Added :code-vector storage-type for memref and (setf memref). Date: Wed Apr 14 08:31:08 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.11 movitz/losp/muerte/memref.lisp:1.12 --- movitz/losp/muerte/memref.lisp:1.11 Tue Apr 6 20:15:02 2004 +++ movitz/losp/muerte/memref.lisp Wed Apr 14 08:31:08 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.11 2004/04/07 00:15:02 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.12 2004/04/14 12:31:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -207,6 +207,43 @@ (:load-lexical (:lexical-binding ,object-var) :eax) (:addl :ebx :ecx) (:movl (:eax :ecx ,(offset-by 4)) :eax))))))) + (:code-vector + ;; A code-vector is like a normal lisp word pointer, + ;; except it's known to point to a code-vector, and + ;; the pointer value is offset by 2. The trick is to + ;; perform this pointer arithmetics while never + ;; keeping a non-lisp-word pointer in a register. + (cond + ((and (eql 0 index) (eql 0 offset)) + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :ebx) ,object) + (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) + (:addl (:ebx ,(offset-by 4)) :eax))) + ((eql 0 offset) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :ecx) ,object ,index) + ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) + `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ecx)) + (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) + (:addl (:ebx :ecx ,(offset-by 4)) :eax))) + ((eql 0 index) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :untagged-fixnum-ecx) ,object ,offset) + (:movl ,(ldb (byte 32 0) (- movitz:+code-vector-word-offset+)) :eax) + (:addl (:ebx :ecx ,(offset-by 4)) :eax))) + (t (error "variable memref type :code-vector not implemented.")) + #+ignore + (t (assert (not (movitz:movitz-constantp offset env))) + (assert (not (movitz:movitz-constantp index env))) + (let ((object-var (gensym "memref-object-"))) + (assert (= 4 movitz:+movitz-fixnum-factor+)) + `(let ((,object-var ,object)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:ecx :ebx) ,offset ,index) + (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding ,object-var) :eax) + (:addl :ebx :ecx) + (:movl (:eax :ecx ,(offset-by 4)) :eax))))))) (t (error "Unknown memref type: ~S" (movitz::eval-form type nil nil)) form))))))))) @@ -454,6 +491,41 @@ `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx)) (:movl :eax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) (t (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-"))) + `(let ((,value-var ,value) (,object-var ,object)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) + `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx)) + (:addl :ebx :ecx) ; index += offset + (:load-lexical (:lexical-binding ,object-var) :ebx) + (:movl :eax (:ebx :ecx)))))))) + (:code-vector + (cond + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) ,value ,object) + (:movl ,movitz:+code-vector-word-offset+ + (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env))))) + (:addl :eax (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env))))))) + ((movitz:movitz-constantp offset env) + (let ((value-var (gensym "memref-value-"))) + `(let ((,value-var ,value)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:ebx :ecx) ,object ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + ,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2)) + `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx)) + (:movl ,movitz:+code-vector-word-offset+ + (:ebx :ecx ,(movitz:movitz-eval offset env))) + (:addl :eax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) + (t (error "variable (setf memref) type :code-vector not implemented.") + #+ignore + (let ((value-var (gensym "memref-value-")) (object-var (gensym "memref-object-"))) `(let ((,value-var ,value) (,object-var ,object)) (with-inline-assembly (:returns :eax) From ffjeld at common-lisp.net Wed Apr 14 12:37:23 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 08:37:23 -0400 Subject: [movitz-cvs] CVS update: movitz/movitz.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv23080 Modified Files: movitz.lisp Log Message: Added constant +code-vector-transient-word+. Date: Wed Apr 14 08:37:23 2004 Author: ffjeld Index: movitz/movitz.lisp diff -u movitz/movitz.lisp:1.5 movitz/movitz.lisp:1.6 --- movitz/movitz.lisp:1.5 Fri Feb 13 17:07:21 2004 +++ movitz/movitz.lisp Wed Apr 14 08:37:23 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:52:58 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: movitz.lisp,v 1.5 2004/02/13 22:07:21 ffjeld Exp $ +;;;; $Id: movitz.lisp,v 1.6 2004/04/14 12:37:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -24,6 +24,10 @@ (define-unsigned lu32 4 :little-endian) (defconstant +code-vector-word-offset+ 2) +(defconstant +code-vector-transient-word+ + (ldb (byte 32 0) + (- +code-vector-word-offset+))) + (defconstant +movitz-multiple-values-limit+ 127) (defvar *bq-level* 0) From ffjeld at common-lisp.net Wed Apr 14 12:40:27 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 08:40:27 -0400 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv2160 Modified Files: image.lisp Log Message: No comment. Date: Wed Apr 14 08:40:26 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.20 movitz/image.lisp:1.21 --- movitz/image.lisp:1.20 Thu Mar 25 20:44:46 2004 +++ movitz/image.lisp Wed Apr 14 08:40:26 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.20 2004/03/26 01:44:46 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.21 2004/04/14 12:40:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1434,6 +1434,7 @@ `(muerte.cl:progn (muerte::with-inline-assembly (:returns :nothing) (:cli) + (:cld) ; clear direction flag => "normal" register GC roots. (:movw ,(1- (* 8 8)) (:esp -6)) (:movl ,(+ (image-ds-segment-base *image*) From ffjeld at common-lisp.net Wed Apr 14 12:41:11 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 08:41:11 -0400 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv3793 Modified Files: packages.lisp Log Message: Added symbols. Date: Wed Apr 14 08:41:11 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.14 movitz/packages.lisp:1.15 --- movitz/packages.lisp:1.14 Tue Apr 6 20:34:06 2004 +++ movitz/packages.lisp Wed Apr 14 08:41:11 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.14 2004/04/07 00:34:06 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.15 2004/04/14 12:41:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1293,7 +1293,8 @@ #:+movitz-fixnum-shift+ #:+movitz-fixnum-zmask+ #:+scan-skip-word+ - #:constant0 + #:+code-vector-word-offset+ + #:+code-vector-transient-word+ #:movitz-object-browser-properties #:movitz-heap-object From ffjeld at common-lisp.net Wed Apr 14 14:38:14 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 10:38:14 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30822 Modified Files: compiler.lisp Log Message: Minor changes, mostly to do with knowing about the effect of the :cld and :stc instructions. Date: Wed Apr 14 10:38:14 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.44 movitz/compiler.lisp:1.45 --- movitz/compiler.lisp:1.44 Tue Apr 13 09:03:10 2004 +++ movitz/compiler.lisp Wed Apr 14 10:38:14 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.44 2004/04/13 13:03:10 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.45 2004/04/14 14:38:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1424,7 +1424,7 @@ (non-destructuve-p (c) (let ((c (ignore-instruction-prefixes c))) (and (consp c) - (member (car c) '(:testl :testb :pushl :cmpl :cmpb :frame-map))))) + (member (car c) '(:testl :testb :pushl :cmpl :cmpb :frame-map :std))))) (simple-instruction-p (c) (let ((c (ignore-instruction-prefixes c))) (and (listp c) @@ -1469,14 +1469,14 @@ (preserves-register-p (i register) (let ((i (ignore-instruction-prefixes i))) (and (not (atom i)) - (or (and (member register '(:edx)) - (member (global-funcall-p i) - '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx))) + (or (and (simple-instruction-p i) + (not (eq register (idst i)))) (instruction-is i :frame-map) (branch-instruction-label i) (non-destructuve-p i) - (and (simple-instruction-p i) - (not (eq register (idst i)))))))) + (and (member register '(:edx)) + (member (global-funcall-p i) + '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx))))))) (register-operand (op) (and (member op '(:eax :ebx :ecx :edx :edi)) op)) @@ -1915,6 +1915,11 @@ (setq p (list `(,(car i) ',to))) (explain nil "branch redirect from ~S to ~S" from to) t))) + ;; remove back-to-back std/cld + ((and (instruction-is i :cld) + (instruction-is i2 :std)) + (explain nil "removing back-to-back cld, std.") + (setq p nil next-pc (cddr pc))) ;; remove branch no-ops. ((and (branch-instruction-label i t) (label-here-p (branch-instruction-label i t) @@ -2455,7 +2460,7 @@ (t (case (instruction-is i) ((nil :call) (return nil)) - ((:into)) + ((:into :clc :stc :cld :std)) ((:jnz :je :jne :jz)) ((:outb) (setf free-so-far @@ -2541,7 +2546,6 @@ (multiple-value-call #'encoded-subtypep (values-list (binding-store-type binding)) (type-specifier-encode '(or integer character)))) - (warn "for ecX: ~S" binding) :ecx) ((not (null free-registers-no-ecx)) (first free-registers-no-ecx)) From ffjeld at common-lisp.net Wed Apr 14 14:39:18 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 10:39:18 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/io-port.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4197 Modified Files: io-port.lisp Log Message: Much changed io-port and (setf io-port), so as to observe the register discipline. Date: Wed Apr 14 10:39:18 2004 Author: ffjeld Index: movitz/losp/muerte/io-port.lisp diff -u movitz/losp/muerte/io-port.lisp:1.8 movitz/losp/muerte/io-port.lisp:1.9 --- movitz/losp/muerte/io-port.lisp:1.8 Thu Feb 26 06:18:29 2004 +++ movitz/losp/muerte/io-port.lisp Wed Apr 14 10:39:18 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Mar 21 22:14:08 2001 ;;;; -;;;; $Id: io-port.lisp,v 1.8 2004/02/26 11:18:29 ffjeld Exp $ +;;;; $Id: io-port.lisp,v 1.9 2004/04/14 14:39:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,30 +25,37 @@ (define-compiler-macro io-port (&whole form port type &environment env) (if (not (movitz:movitz-constantp type env)) form - (ecase (movitz::eval-form type env) + (ecase (movitz:movitz-eval type env) (:unsigned-byte8 - `(with-inline-assembly (:returns :untagged-fixnum-eax) + `(with-inline-assembly (:returns :eax) (:compile-form (:result-mode :edx) ,port) - (:andl ,(ash #xffff movitz::+movitz-fixnum-shift+) :edx) - (:shrl #.movitz::+movitz-fixnum-shift+ :edx) + (:std) ; only EBX is now GC root + (:shrl ,movitz::+movitz-fixnum-shift+ :edx) (:xorl :eax :eax) - (:inb :dx :al))) + (:inb :dx :al) + (:shll ,movitz:+movitz-fixnum-shift+ :eax) + (:movl :edi :edx) + (:cld))) (:unsigned-byte16 - `(with-inline-assembly (:returns :untagged-fixnum-eax) + `(with-inline-assembly (:returns :eax) (:compile-form (:result-mode :edx) ,port) - (:andl ,(ash #xffff movitz::+movitz-fixnum-shift+) :edx) - (:shrl #.movitz::+movitz-fixnum-shift+ :edx) + (:std) + (:shrl ,movitz::+movitz-fixnum-shift+ :edx) (:xorl :eax :eax) - (:inw :dx :ax))) + (:inw :dx :ax) + (:shll ,movitz:+movitz-fixnum-shift+ :eax) + (:movl :edi :edx))) (:character `(with-inline-assembly (:returns :eax) (:compile-form (:result-mode :edx) ,port) - (:andl ,(ash #xffff movitz::+movitz-fixnum-shift+) :edx) + (:std) (:shrl #.movitz::+movitz-fixnum-shift+ :edx) (:xorl :eax :eax) (:inb :dx :al) (:shll 8 :eax) - (:movb ,(movitz::tag :character) :al)))))) + (:movb ,(movitz::tag :character) :al) + (:movl :edi :edx) + (:cld)))))) (defun io-port (port type) (ecase type @@ -60,68 +67,161 @@ (io-port port :character)))) (define-compiler-macro (setf io-port) (&whole form value port type) - (let ((value-code (if (not (movitz:movitz-constantp value)) - `((:compile-form (:result-mode :untagged-fixnum-eax) ,value)) - (let ((port-value (movitz::eval-form value))) - (check-type port-value (unsigned-byte 16)) - (movitz::make-immediate-move port-value :eax))))) + (let ((value-var (gensym "(setf io-port)-value-")) + (port-var (gensym "(setf io-port)-port-")) + #+ignore + (value-eax-code (if (not (movitz:movitz-constantp value)) + `((:compile-form (:result-mode :untagged-fixnum-eax) ,value)) + (let ((port-value (movitz:movitz-eval value))) + (check-type port-value (unsigned-byte 16)) + (movitz::make-immediate-move port-value :eax))))) ;; value-code will put VALUE in eax. (cond ((and (movitz:movitz-constantp type) (movitz:movitz-constantp port)) - (let ((the-port (movitz::eval-form port)) - (the-type (movitz::eval-form type))) + (let ((the-port (movitz:movitz-eval port)) + (the-type (movitz:movitz-eval type))) (etypecase the-port ((unsigned-byte 8) ; short form of outb can be used (ecase the-type (:unsigned-byte8 - `(with-inline-assembly (:returns :untagged-fixnum-eax) - , at value-code - (:outb :al ,the-port))) + `(let ((,value-var ,value)) + (with-inline-assembly-case () + (do-case (:ignore :nothing) + (:std) + (:compile-form (:result-mode :untagged-fixnum-eax) ,value-var) + (:outb :al ,the-port) + (:movl :edi :eax) + (:cld)) + (do-case (t :eax) + (:std) + (:compile-form (:result-mode :untagged-fixnum-eax) ,value-var) + (:outb :al ,the-port) + (:compile-form (:result-mode :eax) ,value-var) + (:cld))))) (:unsigned-byte16 - `(with-inline-assembly (:returns :untagged-fixnum-eax) - , at value-code - (:outw :ax ,the-port))))) + `(let ((,value-var ,value)) + (with-inline-assembly-case () + (do-case (:ignore :nothing) + (:std) + (:compile-form (:result-mode :untagged-fixnum-eax) ,value-var) + (:outw :ax ,the-port) + (:movl :edi :eax) + (:cld)) + (do-case (t :eax) + (:std) + (:compile-form (:result-mode :untagged-fixnum-eax) ,value-var) + (:outw :ax ,the-port) + (:compile-form (:result-mode :eax) ,value-var) + (:cld))))))) ((unsigned-byte 16) ; indirect (by DX) form of outb must be used (ecase the-type (:unsigned-byte8 - `(with-inline-assembly (:returns :untagged-fixnum-eax) - , at value-code - ,@(movitz::make-immediate-move the-port :edx) - (:outb :al :dx))) + `(let ((,value-var ,value)) + (with-inline-assembly-case () + (do-case (:ignore :nothing) + (:std) + (:compile-form (:result-mode :untagged-fixnum-eax) ,value-var) + ,@(movitz::make-immediate-move the-port :edx) + (:outb :al :dx) + ,@(unless (= 0 (mod the-port 4)) + `((:movl :edi :edx))) + (:movl :edi :eax) + (:cld)) + (do-case (t :eax) + (:std) + (:compile-form (:result-mode :untagged-fixnum-eax) ,value-var) + ,@(movitz::make-immediate-move the-port :edx) + (:outb :al :dx) + ,@(unless (= 0 (mod the-port 4)) + `((:movl :edi :edx))) + (:compile-form (:result-mode :eax) ,value-var) + (:cld))))) (:unsigned-byte16 - `(with-inline-assembly (:returns :untagged-fixnum-eax) - , at value-code - ,@(movitz::make-immediate-move the-port :edx) - (:outw :ax :dx)))))))) + `(let ((,value-var ,value)) + (with-inline-assembly-case () + (do-case (:ignore :nothing) + (:std) + (:compile-form (:result-mode :untagged-fixnum-eax) ,value-var) + ,@(movitz::make-immediate-move the-port :edx) + (:outw :ax :dx) + ,@(unless (= 0 (mod the-port 4)) + `((:movl :edi :edx))) + (:movl :edi :eax) + (:cld)) + (do-case (t :eax) + (:std) + (:compile-form (:result-mode :untagged-fixnum-eax) ,value-var) + ,@(movitz::make-immediate-move the-port :edx) + (:outw :ax :dx) + ,@(unless (= 0 (mod the-port 4)) + `((:movl :edi :edx))) + (:compile-form (:result-mode :eax) ,value-var) + (:cld)))))))))) ((movitz:movitz-constantp type) - (ecase (movitz::eval-form type) + (ecase (movitz:movitz-eval type) (:unsigned-byte8 - `(with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-form (:result-mode :push) ,port) - , at value-code - (:popl :edx) - (:shrl #.movitz::+movitz-fixnum-shift+ :edx) - (:outb :al :dx))) + `(let ((,value-var ,value) + (,port-var ,port)) + (with-inline-assembly-case () + (do-case (:ignore :nothing) + (:std) + (:compile-two-forms (:untagged-fixnum-eax :edx) ,value-var ,port-var) + (:shrl #.movitz::+movitz-fixnum-shift+ :edx) + (:outb :al :dx) + (:movl :edi :edx) + (:movl :edi :eax) + (:cld)) + (do-case (t :eax) + (:std) + (:compile-two-forms (:untagged-fixnum-eax :edx) ,value-var ,port-var) + (:shrl #.movitz::+movitz-fixnum-shift+ :edx) + (:outb :al :dx) + (:movl :edi :edx) + (:compile-form (:result-mode :eax) ,value-var) + (:cld))))) (:unsigned-byte16 - `(with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-form (:result-mode :push) ,port) - , at value-code - (:popl :edx) - (:shrl #.movitz::+movitz-fixnum-shift+ :edx) - (:outw :ax :dx))) + `(let ((,value-var ,value) + (,port-var ,port)) + (with-inline-assembly-case () + (do-case (:ignore :nothing) + (:std) + (:compile-two-forms (:untagged-fixnum-eax :edx) ,value-var ,port-var) + (:shrl #.movitz::+movitz-fixnum-shift+ :edx) + (:outw :ax :dx) + (:movl :edi :edx) + (:movl :edi :eax) + (:cld)) + (do-case (t :eax) + (:std) + (:compile-two-forms (:untagged-fixnum-eax :edx) ,value-var ,port-var) + (:shrl #.movitz::+movitz-fixnum-shift+ :edx) + (:outw :ax :dx) + (:movl :edi :edx) + (:compile-form (:result-mode :eax) ,value-var) + (:cld))))) (:character - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :push) ,port) - (:compile-form (:result-mode :eax) ,value) - (:cmpb #.(movitz::tag :character) :al) - (:jne '(:sub-program (not-a-character) (:int 60))) - (:popl :edx) - (:shrl 8 :eax) - (:shrl #.movitz::+movitz-fixnum-shift+ :edx) - (:outb :al :dx) - (:shll 8 :eax) - (:movb 2 :al))))) + `(let ((,value-var ,value) + (,port-var ,port)) + (with-inline-assembly-case () + (do-case (:ignore :nothing) + (:std) + (:compile-two-forms (:untagged-fixnum-eax :edx) ,value-var ,port-var) + (:shrl #.movitz::+movitz-fixnum-shift+ :edx) + (:shrl 8 :eax) + (:outb :al :dx) + (:movl :edi :edx) + (:movl :edi :eax) + (:cld)) + (do-case (t :eax) + (:std) + (:compile-two-forms (:untagged-fixnum-eax :edx) ,value-var ,port-var) + (:shrl #.movitz::+movitz-fixnum-shift+ :edx) + (:shrl 8 :eax) + (:outb :al :dx) + (:movl :edi :edx) + (:compile-form (:result-mode :eax) ,value-var) + (:cld))))))) (t form)))) (defun (setf io-port) (value port type) From ffjeld at common-lisp.net Wed Apr 14 16:38:47 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 12:38:47 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/io-port.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13405 Modified Files: io-port.lisp Log Message: Fixed up %io-port-read-succession and %io-port-write-succession substantially, so as to observe the register discipline. Date: Wed Apr 14 12:38:47 2004 Author: ffjeld Index: movitz/losp/muerte/io-port.lisp diff -u movitz/losp/muerte/io-port.lisp:1.9 movitz/losp/muerte/io-port.lisp:1.10 --- movitz/losp/muerte/io-port.lisp:1.9 Wed Apr 14 10:39:18 2004 +++ movitz/losp/muerte/io-port.lisp Wed Apr 14 12:38:47 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Mar 21 22:14:08 2001 ;;;; -;;;; $Id: io-port.lisp,v 1.9 2004/04/14 14:39:18 ffjeld Exp $ +;;;; $Id: io-port.lisp,v 1.10 2004/04/14 16:38:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -68,14 +68,7 @@ (define-compiler-macro (setf io-port) (&whole form value port type) (let ((value-var (gensym "(setf io-port)-value-")) - (port-var (gensym "(setf io-port)-port-")) - #+ignore - (value-eax-code (if (not (movitz:movitz-constantp value)) - `((:compile-form (:result-mode :untagged-fixnum-eax) ,value)) - (let ((port-value (movitz:movitz-eval value))) - (check-type port-value (unsigned-byte 16)) - (movitz::make-immediate-move port-value :eax))))) - ;; value-code will put VALUE in eax. + (port-var (gensym "(setf io-port)-port-"))) (cond ((and (movitz:movitz-constantp type) (movitz:movitz-constantp port)) @@ -288,7 +281,9 @@ &environment env) (if (not (movitz:movitz-constantp byte-size env)) form - (let ((byte-size (movitz:movitz-eval byte-size env))) + (let ((port-var (gensym "port-var-")) + (object-var (gensym "object-var-")) + (byte-size (movitz:movitz-eval byte-size env))) (cond ((and (movitz:movitz-constantp offset env) (movitz:movitz-constantp start env) @@ -302,136 +297,158 @@ (:32-bit (assert (= 4 movitz:+movitz-fixnum-factor+)) (if (<= 1 count 20) - `(with-inline-assembly-case () - (do-case (t :eax) - (:compile-two-forms (:edx :ebx) ,port ,object) - (:andl ,(cl:* #xffff movitz::+movitz-fixnum-factor+) :edx) + `(let ((,port-var ,port) + (,object-var ,object)) + (with-inline-assembly-case () + (do-case (t :eax) + (:std) + (:compile-two-forms (:edx :ebx) ,port-var ,object-var) + (:shrl ,movitz::+movitz-fixnum-shift+ :edx) + ,@(loop for i from start below end + appending + `((:inl :dx :eax) + (:movl :eax (:ebx ,(+ offset (* 4 i)))))) + (:movl :edi :edx) + (:movl :ebx :eax) + (:cld)))) + `(let ((,port-var ,port) + (,object-var ,object)) + (with-inline-assembly-case () + (do-case (t :eax :labels (io-read-loop end-io-read-loop not-fixnum)) + (:std) + (:compile-two-forms (:edx :ebx) ,port-var ,object-var) (:shrl ,movitz::+movitz-fixnum-shift+ :edx) - ,@(loop for i from start below end - appending - `((:inl :dx :eax) - (:movl :eax (:ebx ,(+ offset (* 4 i)))))) - (:movl :ebx :eax))) - `(with-inline-assembly-case () - (do-case (t :ebx :labels (io-read-loop end-io-read-loop not-fixnum)) - (:compile-two-forms (:edx :ebx) ,port ,object) - (:andl ,(cl:* #xffff movitz::+movitz-fixnum-factor+) :edx) - (:shrl ,movitz::+movitz-fixnum-shift+ :edx) - (:pushl ,(cl:* movitz::+movitz-fixnum-factor+ end)) ; keep end in (:esp) - (:movl ,(cl:* movitz::+movitz-fixnum-factor+ start) :ecx) - io-read-loop - (:cmpl :ecx (:esp)) - (:jbe 'end-io-read-loop) - (:addl 4 :ecx) - (:inl :dx :eax) - (:movl :eax (:ebx ,(+ offset -4) :ecx)) - (:jmp 'io-read-loop) - (:popl :eax) ; increment :esp, and put a lispval in :eax. - end-io-read-loop)))) + (:pushl ,(cl:* movitz::+movitz-fixnum-factor+ end)) ; keep end in (:esp) + (:movl ,(cl:* movitz::+movitz-fixnum-factor+ start) :ecx) + io-read-loop + (:cmpl :ecx (:esp)) + (:jbe 'end-io-read-loop) + (:addl 4 :ecx) + (:inl :dx :eax) + (:movl :eax (:ebx ,(+ offset -4) :ecx)) + (:jmp 'io-read-loop) + end-io-read-loop + (:popl :edx) ; increment :esp, and put a lispval in :edx. + (:movl :ebx :eax) + (:cld)))))) (:16-bit (assert (= 4 movitz:+movitz-fixnum-factor+)) (if (and t (<= 1 count 20)) - `(with-inline-assembly-case () - (do-case (t :ebx) - (:compile-two-forms (:edx :ebx) ,port ,object) - (:andl ,(cl:* #xffff movitz::+movitz-fixnum-factor+) :edx) + `(let ((,port-var ,port) + (,object-var ,object)) + (with-inline-assembly-case () + (do-case (t :eax) + (:std) + (:compile-two-forms (:edx :ebx) ,port-var ,object-var) + (:shrl ,movitz::+movitz-fixnum-shift+ :edx) + ,@(loop for i from start below end + appending + `((:inw :dx :ax) + (:movw :ax (:ebx ,(+ offset (* 2 i)))))) + (:movl :edi :edx) + (:movl :ebx :eax) + (:cld)))) + `(let ((,port-var ,port) + (,object-var ,object)) + (with-inline-assembly-case () + (do-case (t :eax :labels (io-read-loop end-io-read-loop not-fixnum)) + (:std) + (:compile-two-forms (:edx :ebx) ,port-var ,object-var) (:shrl ,movitz::+movitz-fixnum-shift+ :edx) - (:xorl :eax :eax) - ,@(loop for i from start below end - appending - `((:inw :dx :ax) - (:movw :ax (:ebx ,(+ offset (* 2 i)))))))) - `(with-inline-assembly-case () - (do-case (t :ebx :labels (io-read-loop end-io-read-loop not-fixnum)) - (:compile-two-forms (:edx :ebx) ,port ,object) - (:andl ,(cl:* #xffff movitz::+movitz-fixnum-factor+) :edx) - (:shrl ,movitz::+movitz-fixnum-shift+ :edx) - ;; (:pushl ,(cl:* movitz::+movitz-fixnum-factor+ end)) ; keep end in (:esp) - (:movl ,(cl:* 1 start) :ecx) - (:xorl :eax :eax) - io-read-loop - (:cmpl ,end :ecx) - (:ja 'end-io-read-loop) - (:addl 1 :ecx) - (:inw :dx :ax) - (:movw :ax (:ebx ,(+ offset -2) (:ecx 2))) - (:jmp 'io-read-loop) - end-io-read-loop)))) + (:movl ,(cl:* 1 start) :ecx) + io-read-loop + (:cmpl ,end :ecx) + (:ja 'end-io-read-loop) + (:addl 1 :ecx) + (:inw :dx :ax) + (:movw :ax (:ebx ,(+ offset -2) (:ecx 2))) + (:jmp 'io-read-loop) + end-io-read-loop + (:movl :edi :edx) + (:movl :ebx :eax) + (:cld)))))) (t (error "~S byte-size ~S not implemented." (car form) byte-size))))) ((and (movitz:movitz-constantp offset env)) - (let ((offset (movitz:movitz-eval offset env))) + (let ((start-var (gensym "start-")) + (end-var (gensym "end-")) + (offset (movitz:movitz-eval offset env))) (case byte-size (:8-bit (assert (= 4 movitz:+movitz-fixnum-factor+)) - `(with-inline-assembly-case () - (do-case (t :ebx :labels (io-read-loop end-io-read-loop not-fixnum)) - (:compile-form (:result-mode :push) ,port) - (:compile-form (:result-mode :push) ,object) - (:compile-two-forms (:ecx :eax) ,start ,end) - (:popl :ebx) ; object - (:popl :edx) ; port - (:andl #.(cl:* #xffff movitz::+movitz-fixnum-factor+) :edx) - (:andl #.(cl:* #xffff movitz::+movitz-fixnum-factor+) :eax) - (:andl #.(cl:* #xffff movitz::+movitz-fixnum-factor+) :ecx) - (:shrl #.movitz::+movitz-fixnum-shift+ :edx) - (:shrl #.movitz::+movitz-fixnum-shift+ :eax) - (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - (:pushl :eax) ; keep end in (:esp) - io-read-loop - (:cmpl :ecx (:esp)) - (:jbe 'end-io-read-loop) - (:inb :dx :al) - (:addl 1 :ecx) - (:movb :al (:ebx ,(+ offset -1) (:ecx 1))) - (:jmp 'io-read-loop) - (:popl :eax) ; increment :esp, and put a lispval in :eax. - end-io-read-loop))) + `(let ((,port-var ,port) + (,object-var ,object) + (,start-var ,start) + (,end-var ,end)) + (with-inline-assembly-case () + (do-case (t :eax :labels (io-read-loop not-fixnum zero-length)) + (:std) + (:compile-two-forms (:edx :ebx) ,port-var ,object-var) + (:compile-two-forms (:ecx :eax) ,start-var ,end-var) + (:subl :ecx :eax) ; EAX = length + (:jna 'zero-length) + (:shrl ,movitz::+movitz-fixnum-shift+ :edx) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) + (:pushl :eax) ; keep length in (:esp) + io-read-loop + (:inb :dx :al) + (:addl 1 :ecx) + (:subl ,movitz:+movitz-fixnum-factor+ (:esp)) + (:movb :al (:ebx ,(+ offset -1) (:ecx 1))) + (:jnz 'io-read-loop) + (:popl :edx) ; increment :esp, and put a lispval in :edx. + zero-length + (:movl :ebx :eax) + (:cld))))) (:16-bit (assert (= 4 movitz:+movitz-fixnum-factor+)) - `(with-inline-assembly-case () - (do-case (t :ebx :labels (io-read-loop end-io-read-loop not-fixnum)) - (:compile-form (:result-mode :push) ,port) - (:compile-form (:result-mode :push) ,object) - (:compile-two-forms (:ecx :eax) ,start ,end) - (:popl :ebx) ; object - (:popl :edx) ; port - (:andl #.(cl:* #xffff movitz::+movitz-fixnum-factor+) :edx) - (:andl #.(cl:* #xffff movitz::+movitz-fixnum-factor+) :eax) - (:andl #.(cl:* #xffff movitz::+movitz-fixnum-factor+) :ecx) - (:shrl #.movitz::+movitz-fixnum-shift+ :edx) - (:shrl #.movitz::+movitz-fixnum-shift+ :eax) - (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - (:pushl :eax) ; keep end in (:esp) - io-read-loop - (:cmpl :ecx (:esp)) - (:jbe 'end-io-read-loop) - (:inw :dx :ax) - (: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))) + `(let ((,port-var ,port) + (,object-var ,object) + (,start-var ,start) + (,end-var ,end)) + (with-inline-assembly-case () + (do-case (t :eax :labels (io-read-loop not-fixnum zero-length)) + (:std) ; only EBX is GC root now + (:compile-two-forms (:edx :ebx) ,port-var ,object-var) + (:compile-two-forms (:ecx :eax) ,start-var ,end-var) + (:subl :ecx :eax) ; EAX = length + (:jna 'zero-length) + (:shrl ,movitz::+movitz-fixnum-shift+ :edx) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) + (:pushl :eax) ; keep end in (:esp) + io-read-loop + (:inw :dx :ax) + (:addl 2 :ecx) + (:subl ,(* 2 movitz:+movitz-fixnum-factor+) (:esp)) + (:movw :ax (:ebx ,(+ offset -2) (:ecx 1))) + (:jnz 'io-read-loop) + (:popl :edx) ; increment :esp, and put a lispval in :edx. + zero-length + (:movl :ebx :eax) + (:cld))))) (:32-bit (assert (= 4 movitz:+movitz-fixnum-factor+)) - `(with-inline-assembly-case () - (do-case (t :ebx :labels (io-read-loop end-io-read-loop not-fixnum)) - (:compile-form (:result-mode :push) ,port) - (:compile-form (:result-mode :push) ,object) - (:compile-two-forms (:ecx :eax) ,start ,end) - (:popl :ebx) ; object - (:popl :edx) ; port - (:andl #.(cl:* #xffff movitz::+movitz-fixnum-factor+) :edx) - (:shrl #.movitz::+movitz-fixnum-shift+ :edx) - (:pushl :eax) ; keep end in (:esp) - io-read-loop - (:cmpl :ecx (:esp)) - (:jbe 'end-io-read-loop) - (:inl :dx :eax) - (:addl 4 :ecx) - (:movl :eax (:ebx ,(+ offset -4) :ecx)) - (:jmp 'io-read-loop) - (:popl :eax) ; increment :esp, and put a lispval in :eax. - end-io-read-loop))) + `(let ((,port-var ,port) + (,object-var ,object) + (,start-var ,start) + (,end-var ,end)) + (with-inline-assembly-case () + (do-case (t :eax :labels (io-read-loop end-io-read-loop not-fixnum)) + (:std) ; only EBX is GC root now + (:compile-two-forms (:edx :ebx) ,port-var ,object-var) + (:compile-two-forms (:ecx :eax) ,start-var ,end-var) + (:shrl ,movitz::+movitz-fixnum-shift+ :edx) + (:pushl :eax) ; keep end in (:esp) + io-read-loop + (:cmpl :ecx (:esp)) + (:jbe 'end-io-read-loop) + (:inw :dx :ax) + (:addl 4 :ecx) + (:movw :ax (:ebx ,(+ offset -4) :ecx)) + (:jmp 'io-read-loop) + end-io-read-loop + (:popl :edx) ; increment :esp, and put a lispval in :edx. + (:movl :ebx :eax) + (:cld))))) (t (error "~S byte-size ~S not implemented." (car form) byte-size))))) (t (error "Variable offset not implemented.")))))) @@ -451,7 +468,9 @@ &environment env) (if (not (movitz:movitz-constantp byte-size env)) form - (let ((byte-size (movitz:movitz-eval byte-size env))) + (let ((port-var (gensym "port-var-")) + (object-var (gensym "object-var-")) + (byte-size (movitz:movitz-eval byte-size env))) (cond ((and (movitz:movitz-constantp offset env) (movitz:movitz-constantp start env) @@ -465,107 +484,120 @@ (:32-bit (assert (= 4 movitz:+movitz-fixnum-factor+)) (if (<= 1 count 20) - `(with-inline-assembly-case () - (do-case (t :eax) - (:compile-two-forms (:edx :ebx) ,port ,object) - (:andl ,(cl:* #xffff movitz::+movitz-fixnum-factor+) :edx) + `(let ((,port-var ,port) + (,object-var ,object)) + (with-inline-assembly-case () + (do-case (t :eax) + (:std) + (:compile-two-forms (:edx :ebx) ,port-var ,object-var) + (:shrl ,movitz::+movitz-fixnum-shift+ :edx) + ,@(loop for i from start below end + appending + `((:movl (:ebx ,(+ offset (* 4 i))) :eax) + (:outl :eax :dx))) + (:movl :edi :edx) + (:movl :ebx :eax) + (:cld)))) + `(let ((,port-var ,port) + (,object-var ,object)) + (with-inline-assembly-case () + (do-case (t :eax :labels (io-read-loop end-io-read-loop not-fixnum)) + (:std) + (:compile-two-forms (:edx :ebx) ,port-var ,object-var) (:shrl ,movitz::+movitz-fixnum-shift+ :edx) - ,@(loop for i from start below end - appending - `((:movl (:ebx ,(+ offset (* 4 i))) :eax) - (:outl :eax :dx))) - (:movl :ebx :eax))) - `(with-inline-assembly-case () - (do-case (t :ebx :labels (io-read-loop end-io-read-loop not-fixnum)) - (:compile-two-forms (:edx :ebx) ,port ,object) - (:andl ,(cl:* #xffff movitz::+movitz-fixnum-factor+) :edx) - (:shrl ,movitz::+movitz-fixnum-shift+ :edx) - (:pushl ,(cl:* movitz::+movitz-fixnum-factor+ end)) ; keep end in (:esp) - (:movl ,(cl:* movitz::+movitz-fixnum-factor+ start) :ecx) - io-read-loop - (:cmpl :ecx (:esp)) - (:jbe 'end-io-read-loop) - (:addl 4 :ecx) - (:movl (:ebx ,(+ offset -4) :ecx) :eax) - (:outl :eax :dx) - (:jmp 'io-read-loop) - (:popl :eax) ; increment :esp, and put a lispval in :eax. - end-io-read-loop)))) + (:movl ,(cl:* movitz::+movitz-fixnum-factor+ start) :ecx) + io-read-loop + (:cmpl :ecx ,(cl:* movitz::+movitz-fixnum-factor+ end)) ; XXX + (:jbe 'end-io-read-loop) + (:addl 4 :ecx) + (:movl (:ebx ,(+ offset -4) :ecx) :eax) + (:outl :eax :dx) + (:jmp 'io-read-loop) + end-io-read-loop + (:movl :edi :edx) + (:movl :ebx :eax) + (:cld)))))) (t (error "~S byte-size ~S not implemented." (car form) byte-size))))) ((and (movitz:movitz-constantp offset env)) - (let ((offset (movitz:movitz-eval offset env))) + (let ((start-var (gensym "start-")) + (end-var (gensym "end-")) + (offset (movitz:movitz-eval offset env))) (case byte-size (:8-bit - (assert (= 4 movitz:+movitz-fixnum-factor+)) - `(with-inline-assembly-case () - (do-case (t :ebx :labels (io-read-loop end-io-read-loop not-fixnum)) - (:compile-form (:result-mode :push) ,port) - (:compile-form (:result-mode :push) ,object) - (:compile-two-forms (:ecx :eax) ,start ,end) - (:popl :ebx) ; object - (:popl :edx) ; port - (:andl #.(cl:* #xffff movitz::+movitz-fixnum-factor+) :edx) - (:andl #.(cl:* #xffff movitz::+movitz-fixnum-factor+) :eax) - (:andl #.(cl:* #xffff movitz::+movitz-fixnum-factor+) :ecx) - (:shrl #.movitz::+movitz-fixnum-shift+ :edx) - (:shrl #.movitz::+movitz-fixnum-shift+ :eax) - (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - (:pushl :eax) ; keep end in (:esp) - io-read-loop - (:cmpl :ecx (:esp)) - (:jbe 'end-io-read-loop) - (:addl 1 :ecx) - (:movb (:ebx ,(+ offset -1) (:ecx 1)) :al) - (:outb :al :dx) - (:jmp 'io-read-loop) - (:popl :eax) ; increment :esp, and put a lispval in :eax. - end-io-read-loop))) + `(let ((,port-var ,port) + (,object-var ,object) + (,start-var ,start) + (,end-var ,end)) + (with-inline-assembly-case () + (do-case (t :eax :labels (io-read-loop not-fixnum zero-length)) + (:std) + (:compile-two-forms (:edx :ebx) ,port-var ,object-var) + (:compile-two-forms (:ecx :eax) ,start-var ,end-var) + (:subl :ecx :eax) ; EAX = length + (:jna 'zero-length) + (:shrl ,movitz::+movitz-fixnum-shift+ :edx) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) + (:pushl :eax) ; keep end in (:esp) + io-read-loop + (:addl 1 :ecx) + (:subl ,movitz:+movitz-fixnum-factor+ (:esp)) + (:movb (:ebx ,(+ offset -1) (:ecx 1)) :al) + (:outb :al :dx) + (:jnz 'io-read-loop) + (:popl :edx) ; increment :esp, and put a lispval in :edx. + zero-length + (:movl :ebx :eax) + (:cld))))) (:16-bit - (assert (= 4 movitz:+movitz-fixnum-factor+)) - `(with-inline-assembly-case () - (do-case (t :ebx :labels (io-read-loop end-io-read-loop not-fixnum)) - (:compile-form (:result-mode :push) ,port) - (:compile-form (:result-mode :push) ,object) - (:compile-two-forms (:ecx :eax) ,start ,end) - (:popl :ebx) ; object - (:popl :edx) ; port - (:andl #.(cl:* #xffff movitz::+movitz-fixnum-factor+) :edx) - (:andl #.(cl:* #xffff movitz::+movitz-fixnum-factor+) :eax) - (:andl #.(cl:* #xffff movitz::+movitz-fixnum-factor+) :ecx) - (:shrl #.movitz::+movitz-fixnum-shift+ :edx) - (:shrl #.movitz::+movitz-fixnum-shift+ :eax) - (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - (:pushl :eax) ; keep end in (:esp) - io-read-loop - (:cmpl :ecx (:esp)) - (:jbe 'end-io-read-loop) - (: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. - end-io-read-loop))) + `(let ((,port-var ,port) + (,object-var ,object) + (,start-var ,start) + (,end-var ,end)) + (with-inline-assembly-case () + (do-case (t :eax :labels (io-read-loop not-fixnum zero-length)) + (:std) + (:compile-two-forms (:edx :ebx) ,port-var ,object-var) + (:compile-two-forms (:ecx :eax) ,start-var ,end-var) + (:subl :ecx :eax) ; EAX = length + (:jna 'zero-length) + (:shrl ,movitz::+movitz-fixnum-shift+ :edx) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) + (:pushl :eax) ; keep end in (:esp) + io-read-loop + (:addl 2 :ecx) + (:subl ,(* 2 movitz:+movitz-fixnum-factor+) (:esp)) + (:movw (:ebx ,(+ offset -2) (:ecx 1)) :ax) + (:outw :ax :dx) + (:jnz 'io-read-loop) + (:popl :edx) ; increment :esp, and put a lispval in :edx. + zero-length + (:movl :ebx :eax) + (:cld))))) (:32-bit (assert (= 4 movitz:+movitz-fixnum-factor+)) - `(with-inline-assembly-case () - (do-case (t :ebx :labels (io-read-loop end-io-read-loop not-fixnum)) - (:compile-form (:result-mode :push) ,port) - (:compile-form (:result-mode :push) ,object) - (:compile-two-forms (:ecx :eax) ,start ,end) - (:popl :ebx) ; object - (:popl :edx) ; port - (:andl #.(cl:* #xffff movitz::+movitz-fixnum-factor+) :edx) - (:shrl #.movitz::+movitz-fixnum-shift+ :edx) - (:pushl :eax) ; keep end in (:esp) - io-read-loop - (:cmpl :ecx (:esp)) - (:jbe 'end-io-read-loop) - (:addl 4 :ecx) - (:movl (:ebx ,(+ offset -4) :ecx) :eax) - (:outl :eax :dx) - (:jmp 'io-read-loop) - (:popl :eax) ; increment :esp, and put a lispval in :eax. - end-io-read-loop))) + `(let ((,port-var ,port) + (,object-var ,object) + (,start-var ,start) + (,end-var ,end)) + (with-inline-assembly-case () + (do-case (t :eax :labels (io-read-loop not-fixnum end-io-read-loop)) + (:std) + (:compile-two-forms (:edx :ebx) ,port-var ,object-var) + (:compile-two-forms (:ecx :eax) ,start-var ,end-var) + (:shrl ,movitz::+movitz-fixnum-shift+ :edx) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) + (:pushl :eax) ; keep end in (:esp) + io-read-loop + (:cmpl :ecx (:esp)) + (:jbe 'end-io-read-loop) + (:addl 4 :ecx) + (:movl (:ebx ,(+ offset -4) (:ecx 1)) :eax) + (:outl :eax :dx) + (:jmp 'io-read-loop) + end-io-read-loop + (:popl :edx) ; increment :esp, and put a lispval in :edx. + (:movl :ebx :eax) + (:cld))))) (t (error "~S byte-size ~S not implemented." (car form) byte-size))))) (t (error "Variable offset not implemented.")))))) From ffjeld at common-lisp.net Wed Apr 14 16:45:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 12:45:52 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/io-port.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8769 Modified Files: io-port.lisp Log Message: Pass the &environment on to constantp and eval in the (setf io-port) compiler-macro. Date: Wed Apr 14 12:45:52 2004 Author: ffjeld Index: movitz/losp/muerte/io-port.lisp diff -u movitz/losp/muerte/io-port.lisp:1.10 movitz/losp/muerte/io-port.lisp:1.11 --- movitz/losp/muerte/io-port.lisp:1.10 Wed Apr 14 12:38:47 2004 +++ movitz/losp/muerte/io-port.lisp Wed Apr 14 12:45:52 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Mar 21 22:14:08 2001 ;;;; -;;;; $Id: io-port.lisp,v 1.10 2004/04/14 16:38:47 ffjeld Exp $ +;;;; $Id: io-port.lisp,v 1.11 2004/04/14 16:45:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -66,14 +66,14 @@ (:character (io-port port :character)))) -(define-compiler-macro (setf io-port) (&whole form value port type) +(define-compiler-macro (setf io-port) (&whole form value port type &environment env) (let ((value-var (gensym "(setf io-port)-value-")) (port-var (gensym "(setf io-port)-port-"))) (cond - ((and (movitz:movitz-constantp type) - (movitz:movitz-constantp port)) - (let ((the-port (movitz:movitz-eval port)) - (the-type (movitz:movitz-eval type))) + ((and (movitz:movitz-constantp type env) + (movitz:movitz-constantp port env)) + (let ((the-port (movitz:movitz-eval port env)) + (the-type (movitz:movitz-eval type env))) (etypecase the-port ((unsigned-byte 8) ; short form of outb can be used (ecase the-type @@ -151,8 +151,8 @@ `((:movl :edi :edx))) (:compile-form (:result-mode :eax) ,value-var) (:cld)))))))))) - ((movitz:movitz-constantp type) - (ecase (movitz:movitz-eval type) + ((movitz:movitz-constantp type env) + (ecase (movitz:movitz-eval type env) (:unsigned-byte8 `(let ((,value-var ,value) (,port-var ,port)) From ffjeld at common-lisp.net Wed Apr 14 17:54:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 13:54:52 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv31456 Modified Files: primitive-functions.lisp Log Message: Inlined dynamic-find-binding into dynamic-load and dynamic-store. I expect the stack discipline to state that a primitive-function can't call another primitive-function (in general). Date: Wed Apr 14 13:54:51 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.9 movitz/losp/muerte/primitive-functions.lisp:1.10 --- movitz/losp/muerte/primitive-functions.lisp:1.9 Tue Apr 13 09:28:31 2004 +++ movitz/losp/muerte/primitive-functions.lisp Wed Apr 14 13:54:51 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.9 2004/04/13 13:28:31 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.10 2004/04/14 17:54:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -214,7 +214,8 @@ (define-primitive-function dynamic-find-binding (symbol) "Search the stack for a dynamic binding of SYMBOL. On success, return Carry=1, and the address of the - binding in EAX. On failure, return Carry=0 and EAX unmodified." + binding in EAX. On failure, return Carry=0 and EAX unmodified. + Preserves EBX." (with-inline-assembly (:returns :eax) (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) (:jecxz 'fail) @@ -241,16 +242,29 @@ (define-primitive-function dynamic-load (symbol) "Load the dynamic value of SYMBOL into EAX." (with-inline-assembly (:returns :multiple-values) - (:call-global-constant dynamic-find-binding) - (:movl :eax :edx) - (:jnc 'no-binding) - (:movl (:eax) :eax) + (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) + (:jecxz 'no-stack-binding) + (:cmpl :eax (:ecx)) + (:je 'success) + (:locally (:movl (:edi (:edi-offset stack-top)) :edx)) + search-loop + (:cmpl :edx (:ecx 12)) + (:jnc '(:sub-program () (:int 97))) + (:movl (:ecx 12) :ecx) ; parent + (:jecxz 'no-stack-binding) + (:cmpl :eax (:ecx)) ; compare name + (:jne 'search-loop) + ;; fall through on success + success + (:movl :eax :edx) ; Keep symbol in case it's unbound. + (:movl (:ecx 8) :eax) (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax)) (:je '(:sub-program (unbound) (:int 99))) (:ret) - no-binding - ;; take the global value of SYMBOL. - (:movl (:eax #.(bt:slot-offset 'movitz::movitz-symbol 'movitz::value)) :eax) + no-stack-binding + ;; take the global value of SYMBOL, compare it against unbond-value + (:movl :eax :edx) ; Keep symbol in case it's unbound. + (:movl (:eax #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::value)) :eax) (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax)) (:je '(:sub-program (unbound) (:int 99))) (:ret))) @@ -258,26 +272,25 @@ (define-primitive-function dynamic-store (symbol value) "Store VALUE (ebx) in the dynamic binding of SYMBOL (eax)." (with-inline-assembly (:returns :multiple-values) - (:pushl :ebx) ; Save VALUE for later. - (:call-global-constant dynamic-find-binding) - (:jnc 'no-binding) - (:popl :ebx) ; Load back VALUE from stack. + (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) + (:jecxz 'no-binding) + (:cmpl :eax (:ecx)) + (:je 'success) + (:locally (:movl (:edi (:edi-offset stack-top)) :edx)) + search-loop + (:cmpl :edx (:ecx 12)) + (:jnc '(:sub-program () (:int 97))) + (:movl (:ecx 12) :ecx) ; parent + (:jecxz 'no-binding) + (:cmpl :eax (:ecx)) ; compare name + (:jne 'search-loop) + ;; fall through on success + success + (:leal (:ecx 8) :eax) ; location of binding value cell (:movl :ebx (:eax)) ; Store VALUE in binding. (:ret) no-binding - (:popl :ebx) ; Load back VALUE from stack. (:movl :ebx (:eax #.(bt:slot-offset 'movitz::movitz-symbol 'movitz::value))) - (:ret))) - -(define-primitive-function dynamic-boundp (symbol) - "Return NIL iff SYMBOL is not dynamically bound." - (with-inline-assembly (:returns :multiple-values) - (:call-global-constant dynamic-find-binding) - (:jnc 'no-binding) - (:globally (:movl (:edi (:edi-offset t-symbol)) :eax)) - (:ret) - no-binding - (:movl :edi :eax) (:ret))) (define-primitive-function keyword-search () From ffjeld at common-lisp.net Wed Apr 14 19:04:06 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 15:04:06 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv14694 Modified Files: compiler.lisp Log Message: Fixed some widespread confusion in the compiler about lexical function bindings that don't borrow any lexical bindings. This caused e.g. apropos not to work. Date: Wed Apr 14 15:04:06 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.45 movitz/compiler.lisp:1.46 --- movitz/compiler.lisp:1.45 Wed Apr 14 10:38:14 2004 +++ movitz/compiler.lisp Wed Apr 14 15:04:05 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.45 2004/04/14 14:38:14 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.46 2004/04/14 19:04:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2477,18 +2477,23 @@ (tree-search i r)) free-so-far))) ((:load-constant :load-lexical :store-lexical :init-lexvar - :cons-get :endp :incf-lexvar - :local-function-init) + :cons-get :endp :incf-lexvar) + (assert (gethash (instruction-is i) *extended-code-expanders*)) (unless (can-expand-extended-p i frame-map) (return (values nil t))) (let ((exp (expand-extended-code i funobj frame-map))) - (when (tree-search exp '(:call)) + (when (tree-search exp '(:call :local-function-init)) (return nil)) (setf free-so-far (remove-if (lambda (r) (or (tree-search exp r) (tree-search exp (register32-to-low8 r)))) free-so-far)))) + ((:local-function-init) + (destructuring-bind (binding) + (cdr i) + (unless (typep binding 'funobj-binding) + (return nil)))) (t (warn "Dist ~D stopped by ~A" distance i) (return nil))))) @@ -2651,6 +2656,7 @@ ((typep binding 'constant-object-binding)) ((typep binding 'forwarding-binding)) ((typep binding 'borrowed-binding)) + ((typep binding 'funobj-binding)) ((and (typep binding 'fixed-required-function-argument) (plusp (or (car (gethash binding var-counts)) 0))) (prog1 nil ; may need lending-cons @@ -3109,6 +3115,9 @@ (make-load-constant (constant-object binding) result-mode funobj frame-map)) + (funobj-binding + (make-load-constant (function-binding-funobj binding) + result-mode funobj frame-map)) (borrowed-binding (let ((slot (borrowed-binding-reference-slot binding))) (cond @@ -3375,8 +3384,10 @@ (lend-code (loop for bb in (borrowed-bindings sub-funobj) append (make-lend-lexical bb :edx nil)))) (cond + ((typep function-binding 'funobj-binding) + nil) ((null lend-code) - ;; (warn "null lending") + (warn "null lending") (append (make-load-constant sub-funobj :eax funobj frame-map) (make-store-lexical function-binding :eax nil frame-map))) (t (append (make-load-constant sub-funobj :eax funobj frame-map) From ffjeld at common-lisp.net Wed Apr 14 20:03:34 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 16:03:34 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3077 Modified Files: basic-macros.lisp Log Message: Boundp was completely bogus (!). Also added a compiler-macro for boundp. Date: Wed Apr 14 16:03:33 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.8 movitz/losp/muerte/basic-macros.lisp:1.9 --- movitz/losp/muerte/basic-macros.lisp:1.8 Wed Apr 14 08:21:53 2004 +++ movitz/losp/muerte/basic-macros.lisp Wed Apr 14 16:03:33 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.8 2004/04/14 12:21:53 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.9 2004/04/14 20:03:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1026,6 +1026,20 @@ (:compile-form (:result-mode :eax) ,word-form) (:shrl ,(* 4 nibble) :eax) (:andl #xf :eax))) + +(define-compiler-macro boundp (symbol) + `(with-inline-assembly-case () + (do-case (t :boolean-cf=1 :labels (boundp-done)) + (:compile-form (:result-mode :eax) ,symbol) + (:cmpl :edi :eax) + (:je 'boundp-done) ; if ZF=0, then CF=0 + (:call-global-constant dynamic-find-binding) + (:jc 'boundp-done) + (:movl (:eax #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::value)) :eax) + (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax)) + (:je 'boundp-done) + (:stc) + boundp-done))) (require :muerte/setf) From ffjeld at common-lisp.net Wed Apr 14 20:03:38 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 16:03:38 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3183 Modified Files: symbols.lisp Log Message: Boundp was completely bogus (!). Also added a compiler-macro for boundp. Date: Wed Apr 14 16:03:38 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.7 movitz/losp/muerte/symbols.lisp:1.8 --- movitz/losp/muerte/symbols.lisp:1.7 Tue Apr 6 10:30:48 2004 +++ movitz/losp/muerte/symbols.lisp Wed Apr 14 16:03:38 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.7 2004/04/06 14:30:48 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.8 2004/04/14 20:03:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -121,10 +121,7 @@ (movitz-accessor symbol movitz-symbol package)))) (defun boundp (symbol) - (etypecase symbol - (null nil) - (symbol - (not (eq (movitz-accessor symbol movitz-symbol value) 'unbound))))) + (boundp symbol)) (defun makunbound (symbol) (setf (symbol-value symbol) From ffjeld at common-lisp.net Wed Apr 14 20:05:27 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 16:05:27 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9893 Modified Files: memref.lisp Log Message: Fixed the most general case for memref type :unsigned-byte32. Date: Wed Apr 14 16:05:27 2004 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.12 movitz/losp/muerte/memref.lisp:1.13 --- movitz/losp/muerte/memref.lisp:1.12 Wed Apr 14 08:31:08 2004 +++ movitz/losp/muerte/memref.lisp Wed Apr 14 16:05:26 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.12 2004/04/14 12:31:08 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.13 2004/04/14 20:05:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -177,9 +177,7 @@ (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) (:load-lexical (:lexical-binding ,object-var) :eax) (:addl :ebx :ecx) - (:movl (:eax :ecx ,(offset-by 4)) :ecx) - (:cmpl ,movitz::+movitz-most-positive-fixnum+ :ecx) - (:jg '(:sub-program () (:int 4))))))))) + (:movl (:eax :ecx ,(offset-by 4)) :ecx))))))) (:lisp (cond ((and (eql 0 index) (eql 0 offset)) @@ -335,17 +333,24 @@ (:load-lexical (:lexical-binding ,value-var) :ecx) (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) (:movl :ecx (:eax :ebx ,(movitz:movitz-eval offset env))))))) - (t (warn "Compiling unsafely: ~A" form) - `(with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-form (:result-mode :push) ,object) - (:compile-form (:result-mode :push) ,offset) - (:compile-two-forms (:ebx :eax) ,index ,value) - (:popl :ecx) ; offset - (:shrl ,movitz::+movitz-fixnum-shift+ :eax) - (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) - (:addl :ebx :ecx) ; index += offset - (:popl :ebx) ; object - (:movl :eax (:ebx :ecx)))))) + (t (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-")) + (offset-var (gensym "memref-offset-")) + (index-var (gensym "memref-index-"))) + (assert (= 4 movitz:+movitz-fixnum-factor+)) + `(let ((,value-var ,value) + (,object-var ,object) + (,offset-var ,offset) + (,index-var ,index)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:edx :untagged-fixnum-ecx) ,index-var ,offset-var) + (:addl :edx :ecx) ; offset+index in ECX + (:compile-two-forms (:eax :ebx) ,value-var ,object-var) + (:std) + (:shrl ,movitz::+movitz-fixnum-shift+ :eax) + (:movl :eax (:ebx :ecx)) + (:shll ,movitz:+movitz-fixnum-shift+ :eax) + (:cld))))))) (:unsigned-byte16 (cond ((and (movitz:movitz-constantp value env) From ffjeld at common-lisp.net Wed Apr 14 20:10:59 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 16:10:59 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23201 Modified Files: primitive-functions.lisp Log Message: In both dynamic-load and dynamic-store I commented out a safety-check that is really superfluous (assuming the dynamic-env linked list is consistent). This should speed up dynamic variable access a bit. Date: Wed Apr 14 16:10:58 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.10 movitz/losp/muerte/primitive-functions.lisp:1.11 --- movitz/losp/muerte/primitive-functions.lisp:1.10 Wed Apr 14 13:54:51 2004 +++ movitz/losp/muerte/primitive-functions.lisp Wed Apr 14 16:10:58 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.10 2004/04/14 17:54:51 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.11 2004/04/14 20:10:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -246,10 +246,10 @@ (:jecxz 'no-stack-binding) (:cmpl :eax (:ecx)) (:je 'success) - (:locally (:movl (:edi (:edi-offset stack-top)) :edx)) +;;; (:locally (:movl (:edi (:edi-offset stack-top)) :edx)) search-loop - (:cmpl :edx (:ecx 12)) - (:jnc '(:sub-program () (:int 97))) +;;; (:cmpl :edx (:ecx 12)) +;;; (:jnc '(:sub-program () (:int 97))) (:movl (:ecx 12) :ecx) ; parent (:jecxz 'no-stack-binding) (:cmpl :eax (:ecx)) ; compare name @@ -276,10 +276,10 @@ (:jecxz 'no-binding) (:cmpl :eax (:ecx)) (:je 'success) - (:locally (:movl (:edi (:edi-offset stack-top)) :edx)) +;;; (:locally (:movl (:edi (:edi-offset stack-top)) :edx)) search-loop - (:cmpl :edx (:ecx 12)) - (:jnc '(:sub-program () (:int 97))) +;;; (:cmpl :edx (:ecx 12)) +;;; (:jnc '(:sub-program () (:int 97))) (:movl (:ecx 12) :ecx) ; parent (:jecxz 'no-binding) (:cmpl :eax (:ecx)) ; compare name From ffjeld at common-lisp.net Wed Apr 14 21:56:08 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 17:56:08 -0400 Subject: [movitz-cvs] CVS update: movitz/eval.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv1920 Modified Files: eval.lisp Log Message: Re-wrote movitz-constantp more reasonably. Date: Wed Apr 14 17:56:08 2004 Author: ffjeld Index: movitz/eval.lisp diff -u movitz/eval.lisp:1.5 movitz/eval.lisp:1.6 --- movitz/eval.lisp:1.5 Tue Apr 13 12:30:36 2004 +++ movitz/eval.lisp Wed Apr 14 17:56:08 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 2 17:45:05 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: eval.lisp,v 1.5 2004/04/13 16:30:36 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.6 2004/04/14 21:56:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -59,11 +59,7 @@ (defun movitz-constantp (form &optional (environment nil)) (let ((form (translate-program form :cl :muerte.cl))) (typecase form - (boolean t) - (number t) (keyword t) - (character t) - (string t) (symbol (or (movitz-env-get form 'constantp nil environment) (typep (movitz-binding form environment) 'constant-object-binding))) (cons (case (car form) @@ -73,7 +69,8 @@ ((muerte.cl:+ muerte.cl:- muerte.cl:*) (every (lambda (sub-form) (movitz-constantp sub-form environment)) - (cdr form)))))))) + (cdr form))))) + (t t)))) ; anything else is self-evaluating. (defun isconst (x) From ffjeld at common-lisp.net Wed Apr 14 21:59:35 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 17:59:35 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8206 Modified Files: basic-macros.lisp Log Message: Changed the mechanism of define-compile-time-variable. This means that a lot fewer files needs to be executed at boot-time. Date: Wed Apr 14 17:59:35 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.9 movitz/losp/muerte/basic-macros.lisp:1.10 --- movitz/losp/muerte/basic-macros.lisp:1.9 Wed Apr 14 16:03:33 2004 +++ movitz/losp/muerte/basic-macros.lisp Wed Apr 14 17:59:34 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.9 2004/04/14 20:03:33 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.10 2004/04/14 21:59:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -135,12 +135,12 @@ `(defparameter ,name ,value ,documentation))) (defmacro define-compile-time-variable (name value) - `(progn - (eval-when (:compile-toplevel) - (defparameter ,name ,value) - ;; (setf (symbol-value ',name) ,value) - (pushnew ',name (movitz::image-compile-time-variables movitz::*image*))) - (defparameter ,name (get-global-property ',name)))) + (let ((the-value (eval value))) + `(progn + (eval-when (:compile-toplevel) + (defparameter ,name ',the-value) + (pushnew ',name (movitz::image-compile-time-variables movitz::*image*))) + (defparameter ,name ',the-value)))) (defmacro let* (var-list &body body) (labels ((expand (rest-vars body) From ffjeld at common-lisp.net Wed Apr 14 22:01:30 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 18:01:30 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv14368 Modified Files: los-closette.lisp Log Message: Changed the init-form for *standard-effective-slot-readers* from (vector ..) to #(..), so that it's more easily recognized as a constant form. Date: Wed Apr 14 18:01:30 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.6 movitz/losp/muerte/los-closette.lisp:1.7 --- movitz/losp/muerte/los-closette.lisp:1.6 Mon Mar 22 11:38:10 2004 +++ movitz/losp/muerte/los-closette.lisp Wed Apr 14 18:01:30 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.6 2004/03/22 16:38:10 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.7 2004/04/14 22:01:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -912,14 +912,14 @@ done))) (defparameter *standard-effective-slot-readers* - (vector 'standard-effective-slot-reader%0 - 'standard-effective-slot-reader%1 - 'standard-effective-slot-reader%2 - 'standard-effective-slot-reader%3 - 'standard-effective-slot-reader%4 - 'standard-effective-slot-reader%5 - 'standard-effective-slot-reader%6 - 'standard-effective-slot-reader%7) + #(standard-effective-slot-reader%0 + standard-effective-slot-reader%1 + standard-effective-slot-reader%2 + standard-effective-slot-reader%3 + standard-effective-slot-reader%4 + standard-effective-slot-reader%5 + standard-effective-slot-reader%6 + standard-effective-slot-reader%7) "The element at position i is a standard-reader for a slot at position i.") From ffjeld at common-lisp.net Wed Apr 14 22:49:14 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 18:49:14 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cpu-id.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3809 Modified Files: cpu-id.lisp Log Message: Re-wrote cpu-id. This function still has some way to go before it's compliant with (the still very informal) stack and register disciplines. Date: Wed Apr 14 18:49:14 2004 Author: ffjeld Index: movitz/losp/muerte/cpu-id.lisp diff -u movitz/losp/muerte/cpu-id.lisp:1.2 movitz/losp/muerte/cpu-id.lisp:1.3 --- movitz/losp/muerte/cpu-id.lisp:1.2 Mon Jan 19 06:23:46 2004 +++ movitz/losp/muerte/cpu-id.lisp Wed Apr 14 18:49:14 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Apr 15 22:47:13 2002 ;;;; -;;;; $Id: cpu-id.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $ +;;;; $Id: cpu-id.lisp,v 1.3 2004/04/14 22:49:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -91,53 +91,50 @@ octets in c0, c1, c2, and c3. The 16 values returned represent the individual octets of EAX, EBX, EDX, and ECX, also in little-endian order." (when (cpu-586-class-p) - (with-inline-assembly (:returns :multiple-values) pack octets - ;; c0-c1-c2-c3 into eax.. - (:compile-form (:result-mode :eax) c3) - (:compile-form (:result-mode :ecx) c2) - (:shll 8 :eax) - (:xorl :ecx :eax) - (:compile-form (:result-mode :ecx) c1) - (:shll 8 :eax) - (:xorl :ecx :eax) - (:compile-form (:result-mode :ecx) c0) - (:shll #.(cl:- 8 movitz::+movitz-fixnum-shift+) :eax) - (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - (:xorl :ecx :eax) - ;; do actual cpu-id instruction - (:cpuid) - ;; unpack eax, ebx, edx, ecx to 16 values.. - (:call '(:sub-program (unpack-eax) - (:popl (:esp -20)) ; return address - (:pushl :eax) - (:andl #x000000ff (:esp)) - (:shll #.movitz::+movitz-fixnum-shift+ (:esp)) - (:pushl :eax) - (:andl #x0000ff00 (:esp)) - (:shrl #.(cl:- 8 movitz::+movitz-fixnum-shift+) (:esp)) - (:pushl :eax) - (:andl #x00ff0000 (:esp)) - (:shrl #.(cl:- 16 movitz::+movitz-fixnum-shift+) (:esp)) - (:pushl :eax) - (:andl #xff000000 (:esp)) - (:shrl #.(cl:- 24 movitz::+movitz-fixnum-shift+) (:esp)) - (:subl 4 :esp) - (:ret))) - (:movl :ebx :eax) - (:call 'unpack-eax) - (:movl :edx :eax) - (:call 'unpack-eax) - (:movl :ecx :eax) - (:call 'unpack-eax) - ;; return multiple-values (16 values, actually..) - (:movl (:esp #.(cl:* 4 (cl:- 16 1))) :eax) - (:movl (:esp #.(cl:* 4 (cl:- 16 2))) :ebx) - ;; (:leal (:esp #.(cl:* 4 (cl:- 16 3))) :edx) - (:movb 16 :cl) - (:load-constant muerte.cl::values :edx) - (:movl (:edx #.(bt:slot-offset 'movitz::movitz-symbol 'movitz::function-value)) - :esi) ; load new funobj from symbol into ESI - (:call (:esi #.(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector)))))) + (macrolet + ((do-it () + (flet ((make-register-push (register) + `((:pushl ,register) + (:andl #x000000ff (:esp)) + (:shll #.movitz::+movitz-fixnum-shift+ (:esp)) + (:pushl ,register) + (:andl #x0000ff00 (:esp)) + (:shrl #.(cl:- 8 movitz::+movitz-fixnum-shift+) (:esp)) + (:pushl ,register) + (:andl #x00ff0000 (:esp)) + (:shrl #.(cl:- 16 movitz::+movitz-fixnum-shift+) (:esp)) + (:pushl ,register) + (:andl #xff000000 (:esp)) + (:shrl #.(cl:- 24 movitz::+movitz-fixnum-shift+) (:esp))))) + `(with-inline-assembly (:returns :multiple-values) pack octets + ;; c0-c1-c2-c3 into eax.. + (:compile-form (:result-mode :eax) c3) + (:compile-form (:result-mode :ecx) c2) + (:shll 8 :eax) + (:xorl :ecx :eax) + (:compile-form (:result-mode :ecx) c1) + (:shll 8 :eax) + (:xorl :ecx :eax) + (:compile-form (:result-mode :ecx) c0) + (:shll #.(cl:- 8 movitz::+movitz-fixnum-shift+) :eax) + (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) + (:xorl :ecx :eax) + ;; do actual cpu-id instruction + (:cpuid) + ;; unpack eax, ebx, edx, ecx to 16 values.. + ,@(make-register-push :eax) + ,@(make-register-push :ebx) + ,@(make-register-push :edx) + ,@(make-register-push :ecx) + ;; return multiple-values (16 values, actually..) + (:movl (:esp #.(cl:* 4 (cl:- 16 1))) :eax) + (:movl (:esp #.(cl:* 4 (cl:- 16 2))) :ebx) + (:movb 16 :cl) + (:load-constant muerte.cl::values :edx) + (:movl (:edx #.(bt:slot-offset 'movitz::movitz-symbol 'movitz::function-value)) + :esi) ; load new funobj from symbol into ESI + (:call (:esi #.(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector))))))) + (do-it)))) (defconstant +cpu-id-feature-map+ From ffjeld at common-lisp.net Wed Apr 14 22:51:24 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 18:51:24 -0400 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7982 Modified Files: image.lisp Log Message: Dump images according to the new approach to compile-time variables. I.e don't any more insert a property into global-properties for each and every compile-time-variable. Date: Wed Apr 14 18:51:24 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.21 movitz/image.lisp:1.22 --- movitz/image.lisp:1.21 Wed Apr 14 08:40:26 2004 +++ movitz/image.lisp Wed Apr 14 18:51:24 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.21 2004/04/14 12:40:26 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.22 2004/04/14 22:51:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -804,17 +804,18 @@ (movitz-nil) (t (warn "not a symbol for plist: ~S has ~S" symbol plist))))) ;; pull in global properties + (loop for var in (image-compile-time-variables *image*) + do (let ((mname (movitz-read var)) + (mvalue (movitz-read (symbol-value var)))) + (setf (movitz-symbol-value mname) mvalue))) (setf (movitz-constant-block-global-properties constant-block) - (movitz-read (nconc (mapcan #'(lambda (var) - (list (movitz-read var) (movitz-read (symbol-value var)))) - (image-compile-time-variables *image*)) - (list :setf-namespace (movitz-environment-setf-function-names - *movitz-global-environment*) - :trampoline-funcall%1op (find-primitive-function - 'muerte::trampoline-funcall%1op) - :trampoline-funcall%2op (find-primitive-function - 'muerte::trampoline-funcall%2op) - :packages (make-packages-hash)))))) + (movitz-read (list :packages (make-packages-hash) + :setf-namespace (movitz-environment-setf-function-names + *movitz-global-environment*) + :trampoline-funcall%1op (find-primitive-function + 'muerte::trampoline-funcall%1op) + :trampoline-funcall%2op (find-primitive-function + 'muerte::trampoline-funcall%2op))))) (with-binary-file (stream path :check-stream t :direction :output From ffjeld at common-lisp.net Wed Apr 14 23:20:25 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 14 Apr 2004 19:20:25 -0400 Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11592 Modified Files: special-operators.lisp Log Message: Commented out some experimental code for 'not' that's probably no good. Date: Wed Apr 14 19:20:25 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.19 movitz/special-operators.lisp:1.20 --- movitz/special-operators.lisp:1.19 Tue Apr 13 09:07:46 2004 +++ movitz/special-operators.lisp Wed Apr 14 19:20:24 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.19 2004/04/13 13:07:46 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.20 2004/04/14 23:20:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -665,21 +665,21 @@ (#.(append +boolean-modes+ '(:boolean-branch-on-true :boolean-branch-on-false)) (compiler-values (not-values) :returns (complement-boolean-result-mode not-returns))) - ((:eax :function :multiple-values :ebx :edx) - (case result-mode - ((:eax :ebx :ecx :edx :function :multiple-values) - (compiler-values (not-values) - :code (append (not-values :code) - `((:cmpl :edi ,(single-value-register not-returns)) - (:sbbl :ecx :ecx) - (:cmpl ,(1+ (image-nil-word *image*)) - ,(single-value-register not-returns)) - (:adcl 0 :ecx))) - :returns '(:boolean-ecx 1 0))) - (t (compiler-values (not-values) - :code (append (not-values :code) - `((:cmpl :edi ,(single-value-register not-returns)))) - :returns :boolean-zf=1)))) +;;; ((:eax :function :multiple-values :ebx :edx) +;;; (case result-mode +;;; ((:eax :ebx :ecx :edx :function :multiple-values) +;;; (compiler-values (not-values) +;;; :code (append (not-values :code) +;;; `((:cmpl :edi ,(single-value-register not-returns)) +;;; (:sbbl :ecx :ecx) +;;; (:cmpl ,(1+ (image-nil-word *image*)) +;;; ,(single-value-register not-returns)) +;;; (:adcl 0 :ecx))) +;;; :returns '(:boolean-ecx 1 0))) +;;; (t (compiler-values (not-values) +;;; :code (append (not-values :code) +;;; `((:cmpl :edi ,(single-value-register not-returns)))) +;;; :returns :boolean-zf=1)))) ((:eax :function :multiple-values :ebx :ecx :edx) (compiler-values (not-values) :code (append (not-values :code) From ffjeld at common-lisp.net Thu Apr 15 10:45:07 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 06:45:07 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv23234 Modified Files: compiler.lisp Log Message: Only insert stack-checks when the function also has its own stack-frame. Date: Thu Apr 15 06:45:06 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.46 movitz/compiler.lisp:1.47 --- movitz/compiler.lisp:1.46 Wed Apr 14 15:04:05 2004 +++ movitz/compiler.lisp Thu Apr 15 06:45:05 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.46 2004/04/14 19:04:05 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.47 2004/04/15 10:45:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3859,7 +3859,7 @@ and do (setq need-normalized-ecx-p t)))))) (assert (not (minusp stack-setup-size))) (let ((stack-frame-init-code - (append (when (and do-check-stack-p + (append (when (and do-check-stack-p use-stack-frame-p *compiler-auto-stack-checks-p* (not (without-check-stack-limit-p env))) `((,*compiler-local-segment-prefix* From ffjeld at common-lisp.net Thu Apr 15 13:03:16 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 09:03:16 -0400 Subject: [movitz-cvs] CVS update: movitz/bootblock.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26156 Modified Files: bootblock.lisp Log Message: Make sure the parens are balanced! Date: Thu Apr 15 09:03:16 2004 Author: ffjeld Index: movitz/bootblock.lisp diff -u movitz/bootblock.lisp:1.6 movitz/bootblock.lisp:1.7 --- movitz/bootblock.lisp:1.6 Mon Jan 19 05:36:12 2004 +++ movitz/bootblock.lisp Thu Apr 15 09:03:16 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:47:19 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: bootblock.lisp,v 1.6 2004/01/19 10:36:12 ffjeld Exp $ +;;;; $Id: bootblock.lisp,v 1.7 2004/04/15 13:03:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -296,7 +296,7 @@ ;; Data welcome (% format 8 "Loading Movitz ~D..~% " ,(incf *bootblock-build*)) - entering (% format 8 "~% Enter..") + entering (% format 8 ")~% Enter..") error (% format 8 "Failed!)") track-start-msg (% format 8 "(") track-end-msg (% format 8 ")") From ffjeld at common-lisp.net Thu Apr 15 13:04:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 09:04:52 -0400 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv2976 Modified Files: image.lisp Log Message: Move the initialization of the interrupt-handler array to inside dump-image, so that we can capture the function-value of interrupt-default-handler. Date: Thu Apr 15 09:04:52 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.22 movitz/image.lisp:1.23 --- movitz/image.lisp:1.22 Wed Apr 14 18:51:24 2004 +++ movitz/image.lisp Thu Apr 15 09:04:51 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.22 2004/04/14 22:51:24 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.23 2004/04/15 13:04:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -683,8 +683,6 @@ (ldb (byte 3 0) (image-nil-word *image*)) (tag :null)) (setf (image-constant-block *image*) (make-movitz-constant-block)) - (setf (movitz-constant-block-interrupt-handlers (image-constant-block *image*)) - (movitz-read (make-array 256 :initial-element 'muerte::interrupt-default-handler))) (setf (movitz-constant-block-interrupt-descriptor-table (image-constant-block *image*)) (movitz-read (make-initial-interrupt-descriptors))) (setf (image-t-symbol *image*) (movitz-read t)) @@ -726,6 +724,9 @@ (assert (plusp (dump-count *image*)))) (setf (movitz-symbol-value (movitz-read 'muerte:*build-number*)) (1+ *bootblock-build*)) + (let ((handler (movitz-env-symbol-function 'muerte::interrupt-default-handler))) + (setf (movitz-constant-block-interrupt-handlers (image-constant-block *image*)) + (movitz-read (make-array 256 :initial-element handler)))) (let ((load-address (image-start-address *image*))) (setf (image-cons-pointer *image*) (- load-address (image-ds-segment-base *image*)) From ffjeld at common-lisp.net Thu Apr 15 13:06:18 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 09:06:18 -0400 Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7000 Modified Files: special-operators.lisp Log Message: Added special operator no-macro-call. (no-macro-call foo ...) is just like (foo ...), except no macro or compiler-macro is accepted as foo, only a regular function call. Date: Thu Apr 15 09:06:18 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.20 movitz/special-operators.lisp:1.21 --- movitz/special-operators.lisp:1.20 Wed Apr 14 19:20:24 2004 +++ movitz/special-operators.lisp Thu Apr 15 09:06:18 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.20 2004/04/14 23:20:24 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.21 2004/04/15 13:06:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1134,6 +1134,13 @@ (compiler-values ())) ;;; + +(define-special-operator muerte::no-macro-call (&all all &form form) + (destructuring-bind (operator &rest arguments) + (cdr form) + (compiler-call #'compile-apply-symbol + :forward all + :form (cons operator arguments)))) (define-special-operator muerte::do-result-mode-case (&all all &result-mode result-mode &form form) (loop for (cases . then-forms) in (cddr form) From ffjeld at common-lisp.net Thu Apr 15 13:07:24 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 09:07:24 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8903 Modified Files: primitive-functions.lisp Log Message: Slightly more efficient dynamic-store. Date: Thu Apr 15 09:07:24 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.11 movitz/losp/muerte/primitive-functions.lisp:1.12 --- movitz/losp/muerte/primitive-functions.lisp:1.11 Wed Apr 14 16:10:58 2004 +++ movitz/losp/muerte/primitive-functions.lisp Thu Apr 15 09:07:24 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.11 2004/04/14 20:10:58 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.12 2004/04/15 13:07:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -270,7 +270,8 @@ (:ret))) (define-primitive-function dynamic-store (symbol value) - "Store VALUE (ebx) in the dynamic binding of SYMBOL (eax)." + "Store VALUE (ebx) in the dynamic binding of SYMBOL (eax). + Preserves EBX and EAX." (with-inline-assembly (:returns :multiple-values) (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) (:jecxz 'no-binding) @@ -286,8 +287,7 @@ (:jne 'search-loop) ;; fall through on success success - (:leal (:ecx 8) :eax) ; location of binding value cell - (:movl :ebx (:eax)) ; Store VALUE in binding. + (:movl :ebx (:ecx 8)) ; Store VALUE in binding. (:ret) no-binding (:movl :ebx (:eax #.(bt:slot-offset 'movitz::movitz-symbol 'movitz::value))) From ffjeld at common-lisp.net Thu Apr 15 13:08:50 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 09:08:50 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10967 Modified Files: integers.lisp Log Message: Removed truncate%2ops, better to use numargs-case in truncate. Date: Thu Apr 15 09:08:50 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.4 movitz/losp/muerte/integers.lisp:1.5 --- movitz/losp/muerte/integers.lisp:1.4 Wed Mar 31 21:12:22 2004 +++ movitz/losp/muerte/integers.lisp Thu Apr 15 09:08:50 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.4 2004/04/01 02:12:22 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.5 2004/04/15 13:08:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -701,27 +701,11 @@ ;;; Division -(define-compiler-macro truncate (number &optional (divisor 1)) +(define-compiler-macro truncate (&whole form number &optional (divisor 1)) `(do-result-mode-case () (:plural - (truncate%2ops ,number ,divisor)) + (no-macro-call , at form)) (t (truncate%2ops%1ret ,number ,divisor)))) - -(defun truncate%2ops (number divisor) - (with-inline-assembly (:returns :multiple-values) - (:compile-form (:result-mode :eax) number) - (:compile-form (:result-mode :ebx) divisor) - (:movl :eax :ecx) - (:orl :ebx :ecx) - (:testb #.movitz::+movitz-fixnum-zmask+ :cl) - (:jnz '(:sub-program (not-integer) (:int 107))) - (:cdq :eax :edx) - (:idivl :ebx :eax :edx) - (:shll #.movitz::+movitz-fixnum-shift+ :eax) - (:movl :edx :ebx) - (:xorl :ecx :ecx) - (:movb 2 :cl) ; return values: qutient, remainder. - (:stc))) (defun truncate%2ops%1ret (number divisor) (with-inline-assembly (:returns :multiple-values) @@ -755,7 +739,24 @@ (t form))) (defun truncate (number &optional (divisor 1)) - (truncate number divisor)) + (numargs-case + (1 (number) + number) + (t (number divisor) + (with-inline-assembly (:returns :multiple-values) + (:compile-form (:result-mode :eax) number) + (:compile-form (:result-mode :ebx) divisor) + (:movl :eax :ecx) + (:orl :ebx :ecx) + (:testb #.movitz::+movitz-fixnum-zmask+ :cl) + (:jnz '(:sub-program (not-integer) (:int 107))) + (:cdq :eax :edx) + (:idivl :ebx :eax :edx) + (:shll #.movitz::+movitz-fixnum-shift+ :eax) + (:movl :edx :ebx) + (:xorl :ecx :ecx) + (:movb 2 :cl) ; return values: qutient, remainder. + (:stc))))) (defun round (number &optional (divisor 1)) From ffjeld at common-lisp.net Thu Apr 15 13:10:37 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 09:10:37 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18594 Modified Files: integers.lisp Log Message: (truncate x) should return x and 0. Date: Thu Apr 15 09:10:37 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.5 movitz/losp/muerte/integers.lisp:1.6 --- movitz/losp/muerte/integers.lisp:1.5 Thu Apr 15 09:08:50 2004 +++ movitz/losp/muerte/integers.lisp Thu Apr 15 09:10:37 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.5 2004/04/15 13:08:50 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.6 2004/04/15 13:10:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -741,7 +741,7 @@ (defun truncate (number &optional (divisor 1)) (numargs-case (1 (number) - number) + (values number 0)) (t (number divisor) (with-inline-assembly (:returns :multiple-values) (:compile-form (:result-mode :eax) number) From ffjeld at common-lisp.net Thu Apr 15 13:16:28 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 09:16:28 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/eval.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6334 Modified Files: eval.lisp Log Message: Explicitly name anonymbous lambda functions that eval creates. Date: Thu Apr 15 09:16:28 2004 Author: ffjeld Index: movitz/losp/muerte/eval.lisp diff -u movitz/losp/muerte/eval.lisp:1.5 movitz/losp/muerte/eval.lisp:1.6 --- movitz/losp/muerte/eval.lisp:1.5 Thu Apr 1 15:25:07 2004 +++ movitz/losp/muerte/eval.lisp Thu Apr 15 09:16:28 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.5 2004/04/01 20:25:07 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.6 2004/04/15 13:16:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -323,13 +323,14 @@ ((lambda) (let ((lambda-list (cadr function-name)) (lambda-body (cddr function-name))) - (lambda (&rest args) - (declare (dynamic-extent args)) - (eval-progn lambda-body - (make-destructuring-env lambda-list args env - :environment-p nil - :recursive-p nil - :whole-p nil))))))))) + (install-funobj-name :anonymous-lambda + (lambda (&rest args) + (declare (dynamic-extent args)) + (eval-progn lambda-body + (make-destructuring-env lambda-list args env + :environment-p nil + :recursive-p nil + :whole-p nil)))))))))) (defun lookup-setf-function (name) (let ((setf-name (gethash name (get-global-property :setf-namespace)))) From ffjeld at common-lisp.net Thu Apr 15 13:17:51 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 09:17:51 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv9158 Modified Files: debugger.lisp Log Message: Don't conflate interrupt frames by default. Date: Thu Apr 15 09:17:50 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.7 movitz/losp/x86-pc/debugger.lisp:1.8 --- movitz/losp/x86-pc/debugger.lisp:1.7 Sun Apr 11 14:56:31 2004 +++ movitz/losp/x86-pc/debugger.lisp Thu Apr 15 09:17:50 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.7 2004/04/11 18:56:31 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.8 2004/04/15 13:17:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -455,7 +455,7 @@ ((:fresh-lines *backtrace-do-fresh-lines*) *backtrace-do-fresh-lines*) (conflate *backtrace-do-conflate*) (length *backtrace-length*) - print-returns + print-returns conflate-interrupts ((:print-frames *backtrace-print-frames*) *backtrace-print-frames*)) (let ((*print-safely* t) (*standard-output* *debug-io*) @@ -483,7 +483,7 @@ (integer (let* ((interrupt-frame stack-frame) (funobj (interrupt-frame-ref interrupt-frame :esi :lisp))) - (if (and conflate + (if (and conflate-interrupts conflate ;; When the interrupted function has a stack-frame, conflate it. (typep funobj 'function) (= 1 (ldb (byte 1 5) (funobj-debug-info funobj)))) From ffjeld at common-lisp.net Thu Apr 15 13:18:49 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 09:18:49 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9771 Modified Files: interrupt.lisp Log Message: The interrupt-handlers array now contains the function objects themselves rather than symbols. Date: Thu Apr 15 09:18:49 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.3 movitz/losp/muerte/interrupt.lisp:1.4 --- movitz/losp/muerte/interrupt.lisp:1.3 Tue Apr 13 12:55:17 2004 +++ movitz/losp/muerte/interrupt.lisp Thu Apr 15 09:18:48 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.3 2004/04/13 16:55:17 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.4 2004/04/15 13:18:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -111,18 +111,12 @@ (:locally (:pushl (:edi (:edi-offset num-values)))) ;; call handler - (:movl (:ebp 4) :ebx) ; interrupt number into EBX + (:movl (:ebp 4) :ecx) ; interrupt number into ECX (:locally (:movl (:edi (:edi-offset interrupt-handlers)) :eax)) - (:movl (:eax 2 (:ebx 4)) :eax) ; symbol at (aref EBX interrupt-handlers) into :esi - (:leal (:eax -7) :ecx) - (:testb 7 :cl) - (:jnz 'skip-interrupt-handler) ; if it's not a symbol, never mind. - (:movl (:eax #.(movitz::slot-offset 'movitz::movitz-symbol 'movitz::function-value)) - :esi) ; load new funobj from symbol into ESI + (:movl (:eax 2 (:ecx 4)) :esi) ; funobj at (aref EBX interrupt-handlers) into :esi (:movl :ebp :ebx) ; pass interrupt-frame as arg1 - ;; (:movl :ebx (:ebp -4)) ; put interrupt-frame as our fake stack-frame's funobj. - (:movl (:ebp 4) :eax) ; pass interrupt number as arg 0. - (:shll #.movitz::+movitz-fixnum-shift+ :eax) + (:movl (:ebp 4) :ecx) ; pass interrupt number as arg 0. + (:leal ((:ecx #.movitz:+movitz-fixnum-factor+)) :eax) (:call (:esi #.(movitz::slot-offset 'movitz::movitz-funobj 'movitz::code-vector%2op))) skip-interrupt-handler @@ -251,8 +245,7 @@ (svref vector n))) (defun (setf interrupt-handler) (handler n) - (check-type handler symbol) - (assert (fboundp handler)) + (check-type handler function) (let ((vector (load-global-constant interrupt-handlers))) (setf (svref vector n) handler))) From ffjeld at common-lisp.net Thu Apr 15 13:21:43 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 09:21:43 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv20474 Modified Files: los0-gc.lisp Log Message: Fixed install-los0-consing to reflect the new scheme where interrupt-handlers are now denoted by functions rather than symbols. Date: Thu Apr 15 09:21:42 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.7 movitz/losp/los0-gc.lisp:1.8 --- movitz/losp/los0-gc.lisp:1.7 Sun Apr 11 14:57:06 2004 +++ movitz/losp/los0-gc.lisp Thu Apr 15 09:21:42 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.7 2004/04/11 18:57:06 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.8 2004/04/15 13:21:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -113,7 +113,11 @@ (symbol-function 'new-malloc-clumps)) (setf (symbol-function 'new-malloc-clumps) old-malloc)) - (setf (interrupt-handler 113) 'los0-handle-out-of-memory) + (setf (interrupt-handler 113) + (lambda (exception interrupt-frame) + (declare (ignore exception interrupt-frame)) + (format t "~&;; Handling out-of-memory exception..") + (stop-and-copy))) (values)) (defun install-old-consing () From ffjeld at common-lisp.net Thu Apr 15 15:11:44 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 11:11:44 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4440 Modified Files: conditions.lisp Log Message: Added conditions arithmetic-error and division-by-zero. Date: Thu Apr 15 11:11:44 2004 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.4 movitz/losp/muerte/conditions.lisp:1.5 --- movitz/losp/muerte/conditions.lisp:1.4 Tue Apr 6 10:05:18 2004 +++ movitz/losp/muerte/conditions.lisp Thu Apr 15 11:11:44 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.4 2004/04/06 14:05:18 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.5 2004/04/15 15:11:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -128,7 +128,23 @@ (:report (lambda (c s) (format s "End of file encountered on ~W." (stream-error-stream c))))) - + +(define-condition arithmetic-error (error) + ((operation + :initarg :operation + :initform nil + :reader arithmetic-error-operation) + (operands + :initarg :operands + :initform nil + :reader arithmetic-error-operands))) + +(define-condition division-by-zero (arithmetic-error) + () + (:report (lambda (c s) + (declare (ignore c)) + (format s "Division by zero.")))) + (defun make-condition (type &rest slot-initializations) (declare (dynamic-extent slot-initializations)) (apply 'make-instance type slot-initializations)) From ffjeld at common-lisp.net Thu Apr 15 15:18:43 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 11:18:43 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21357 Modified Files: interrupt.lisp Log Message: Signal a proper division-by-zero condition. Date: Thu Apr 15 11:18:43 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.4 movitz/losp/muerte/interrupt.lisp:1.5 --- movitz/losp/muerte/interrupt.lisp:1.4 Thu Apr 15 09:18:48 2004 +++ movitz/losp/muerte/interrupt.lisp Thu Apr 15 11:18:43 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.4 2004/04/15 13:18:48 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.5 2004/04/15 15:18:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -159,7 +159,7 @@ (*last-interrupt-frame* interrupt-frame)) (block nil (case number - (0 (error "Division by zero.")) + (0 (error 'division-by-zero)) (3 (break "Break instruction at ~@Z." $eip)) (6 (error "Illegal instruction at ~@Z." $eip)) (13 (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z" From ffjeld at common-lisp.net Thu Apr 15 15:23:31 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 11:23:31 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv3578 Modified Files: los0-gc.lisp Log Message: Re-named the muerte:interrupt-handler accessor to muerte:exception-handler. Date: Thu Apr 15 11:23:31 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.8 movitz/losp/los0-gc.lisp:1.9 --- movitz/losp/los0-gc.lisp:1.8 Thu Apr 15 09:21:42 2004 +++ movitz/losp/los0-gc.lisp Thu Apr 15 11:23:31 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.8 2004/04/15 13:21:42 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.9 2004/04/15 15:23:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -113,7 +113,7 @@ (symbol-function 'new-malloc-clumps)) (setf (symbol-function 'new-malloc-clumps) old-malloc)) - (setf (interrupt-handler 113) + (setf (exception-handler 113) (lambda (exception interrupt-frame) (declare (ignore exception interrupt-frame)) (format t "~&;; Handling out-of-memory exception..") From ffjeld at common-lisp.net Thu Apr 15 15:23:36 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 11:23:36 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4090 Modified Files: interrupt.lisp Log Message: Re-named the muerte:interrupt-handler accessor to muerte:exception-handler. Date: Thu Apr 15 11:23:36 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.5 movitz/losp/muerte/interrupt.lisp:1.6 --- movitz/losp/muerte/interrupt.lisp:1.5 Thu Apr 15 11:18:43 2004 +++ movitz/losp/muerte/interrupt.lisp Thu Apr 15 11:23:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.5 2004/04/15 15:18:43 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.6 2004/04/15 15:23:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -240,15 +240,14 @@ nil)))) -(defun interrupt-handler (n) +(defun exception-handler (n) (let ((vector (load-global-constant interrupt-handlers))) (svref vector n))) -(defun (setf interrupt-handler) (handler n) +(defun (setf exception-handler) (handler n) (check-type handler function) (let ((vector (load-global-constant interrupt-handlers))) (setf (svref vector n) handler))) - (defun cli () (with-inline-assembly (:returns :nothing) From ffjeld at common-lisp.net Thu Apr 15 15:23:53 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 11:23:53 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv4518 Modified Files: debugger.lisp Log Message: Minor edits. Date: Thu Apr 15 11:23:53 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.8 movitz/losp/x86-pc/debugger.lisp:1.9 --- movitz/losp/x86-pc/debugger.lisp:1.8 Thu Apr 15 09:17:50 2004 +++ movitz/losp/x86-pc/debugger.lisp Thu Apr 15 11:23:53 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.8 2004/04/15 13:17:50 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.9 2004/04/15 15:23:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -50,6 +50,7 @@ muerte::eval-cons muerte::eval-funcall muerte::eval-form + muerte::eval-progn muerte::slow-method-lookup muerte::do-slow-method-lookup muerte::initial-discriminating-function @@ -499,8 +500,8 @@ (function (let ((delta (code-vector-offset (funobj-code-vector funobj) eip))) (if delta - (format t "{Interrupt ~D in ~W at offset ~D. [#x~X]}" - exception (funobj-name funobj) delta interrupt-frame) + (format t "{Interrupt ~D in ~W at PC offset ~D." + exception (funobj-name funobj) delta) (format t "{Interrupt ~D in ~W at EIP=#x~X. [#x~X]}" exception (funobj-name funobj) eip interrupt-frame)))) (t (format t "{Interrupt ~D with ESI=#x~Z and EIP=#x~X. [#x~X]}" From ffjeld at common-lisp.net Thu Apr 15 15:24:31 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 11:24:31 -0400 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv9504 Modified Files: packages.lisp Log Message: Re-named interrupt-handler to exception-handler. Date: Thu Apr 15 11:24:31 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.15 movitz/packages.lisp:1.16 --- movitz/packages.lisp:1.15 Wed Apr 14 08:41:11 2004 +++ movitz/packages.lisp Thu Apr 15 11:24:31 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.15 2004/04/14 12:41:11 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.16 2004/04/15 15:24:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1114,7 +1114,7 @@ #:stack-frame-ref #:check-stack-limit #:interrupt-frame-ref - #:interrupt-handler + #:exception-handler #:*build-number* #:*error-no-condition-for-debugger* From ffjeld at common-lisp.net Thu Apr 15 18:53:15 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 14:53:15 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16197 Modified Files: functions.lisp Log Message: movitz::constant0 is not exported. Date: Thu Apr 15 14:53:15 2004 Author: ffjeld Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.8 movitz/losp/muerte/functions.lisp:1.9 --- movitz/losp/muerte/functions.lisp:1.8 Wed Apr 14 08:25:27 2004 +++ movitz/losp/muerte/functions.lisp Thu Apr 15 14:53:15 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.8 2004/04/14 12:25:27 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.9 2004/04/15 18:53:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -272,7 +272,7 @@ (assert (below index (funobj-num-constants funobj)) (index) "Index ~D out of range, ~S has ~D constants." index funobj (funobj-num-constants funobj)) (if (>= index (funobj-num-jumpers funobj)) - (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:constant0) index :lisp) + (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0) index :lisp) ;; For a jumper, return its offset relative to the code-vector. ;; This is tricky wrt. to potential GC interrupts, because we're doing ;; pointer arithmetics. @@ -281,7 +281,7 @@ (:movl #.movitz:+code-vector-transient-word+ :ebx) (:addl (:eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) :ebx) ; code-vector (word) into ebx - (:subl (:eax :ecx #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:constant0)) + (:subl (:eax :ecx #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0)) :ebx) (:negl :ebx) (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :eax)))) @@ -291,7 +291,7 @@ (assert (below index (funobj-num-constants funobj)) (index) "Index ~D out of range, ~S has ~D constants." index funobj (funobj-num-constants funobj)) (if (>= index (funobj-num-jumpers funobj)) - (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:constant0) + (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0) index :lisp) value) (progn @@ -301,7 +301,7 @@ (progn ;; without-gc (with-inline-assembly (:returns :nothing) (:compile-two-forms (:eax :ecx) funobj index) - (:leal (:ecx :eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:constant0)) + (:leal (:ecx :eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0)) :ebx) ; dest. address into ebx. (:compile-form (:result-mode :untagged-fixnum-ecx) value) (:addl (:eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) From ffjeld at common-lisp.net Thu Apr 15 19:56:59 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 15:56:59 -0400 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv17093 Modified Files: packages.lisp Log Message: Removed the defpackage form from debugger.lisp, moved the exported symbols to packages.lisp. Date: Thu Apr 15 15:56:59 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.16 movitz/packages.lisp:1.17 --- movitz/packages.lisp:1.16 Thu Apr 15 11:24:31 2004 +++ movitz/packages.lisp Thu Apr 15 15:56:59 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.16 2004/04/15 15:24:31 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.17 2004/04/15 19:56:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1103,6 +1103,20 @@ print-unreadable-movitz-object #:*print-safely* + + #:*debugger-function* + #:*debugger-condition* + #:*backtrace-conflate-names* + #:*backtrace-do-conflate* + #:*backtrace-max-frames* + #:*backtrace-max-args* + #:*backtrace-on-error* + #:*backtrace-stack-frame-barrier* + #:*backtrace-do-fresh-lines* + #:*backtrace-be-spartan-p* + #:*backtrace-print-length* + #:*backtrace-print-level* + #:backtrace #:stack-ref #:with-each-dynamic-context From ffjeld at common-lisp.net Thu Apr 15 19:57:11 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 15:57:11 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv17453 Modified Files: debugger.lisp Log Message: Removed the defpackage form from debugger.lisp, moved the exported symbols to packages.lisp. Date: Thu Apr 15 15:57:11 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.9 movitz/losp/x86-pc/debugger.lisp:1.10 --- movitz/losp/x86-pc/debugger.lisp:1.9 Thu Apr 15 11:23:53 2004 +++ movitz/losp/x86-pc/debugger.lisp Thu Apr 15 15:57:10 2004 @@ -10,28 +10,11 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.9 2004/04/15 15:23:53 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.10 2004/04/15 19:57:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (provide :x86-pc/debugger) - -(defpackage muerte - ;; (:use #:muerte.cl #:muerte #:muerte.x86-pc) - (:export #:*debugger-function* - #:*debugger-condition* - #:*backtrace-conflate-names* - #:*backtrace-do-conflate* - #:*backtrace-max-frames* - #:*backtrace-max-args* - #:*backtrace-on-error* - #:*backtrace-stack-frame-barrier* - #:*backtrace-do-fresh-lines* - #:*backtrace-be-spartan-p* - #:*backtrace-print-length* - #:*backtrace-print-level* - #:backtrace - )) (in-package muerte) From ffjeld at common-lisp.net Thu Apr 15 19:58:21 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 15 Apr 2004 15:58:21 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv20313 Modified Files: compiler.lisp Log Message: Argh, don't ask. Date: Thu Apr 15 15:58:20 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.47 movitz/compiler.lisp:1.48 --- movitz/compiler.lisp:1.47 Thu Apr 15 06:45:05 2004 +++ movitz/compiler.lisp Thu Apr 15 15:58:20 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.47 2004/04/15 10:45:05 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.48 2004/04/15 19:58:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2701,8 +2701,7 @@ (truncate (or (position-if (lambda (i) (member b (find-read-bindings i))) - (cdr init-pc) - :end 10) + (cdr init-pc)) 15) count))))))))) ;; First, make several passes while trying to locate bindings From ffjeld at common-lisp.net Fri Apr 16 08:57:29 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 04:57:29 -0400 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5331 Modified Files: image.lisp Log Message: Fixed warning about multiboot header too far away. Date: Fri Apr 16 04:57:29 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.23 movitz/image.lisp:1.24 --- movitz/image.lisp:1.23 Thu Apr 15 09:04:51 2004 +++ movitz/image.lisp Fri Apr 16 04:57:29 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.23 2004/04/15 13:04:51 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.24 2004/04/16 08:57:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -890,7 +890,9 @@ (warn "Multiboot load-address #x~x is below the 1MB mark." load-address)) (when (> (+ mb-file-position (sizeof mb)) 8192) - (warn "Multiboot header at position ~D is above the 8KB mark.")) + (warn "Multiboot header at position ~D is above the 8KB mark, ~ +this image will not be Multiboot compatible." + (+ mb-file-position (sizeof mb)))) (assert (file-position stream mb-file-position) () "Couldn't set file-position for ~W to ~W." (pathname stream) From ffjeld at common-lisp.net Fri Apr 16 10:24:54 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 06:24:54 -0400 Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv3021 Modified Files: special-operators.lisp Log Message: Commented out warning thats not really supposed to be there. Date: Fri Apr 16 06:24:54 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.21 movitz/special-operators.lisp:1.22 --- movitz/special-operators.lisp:1.21 Thu Apr 15 09:06:18 2004 +++ movitz/special-operators.lisp Fri Apr 16 06:24:54 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.21 2004/04/15 13:06:18 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.22 2004/04/16 10:24:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -686,6 +686,7 @@ `((:cmpl :edi ,(single-value-register not-returns)))) :returns :boolean-zf=1)) ; TRUE iff result equal to :edi/NIL. (otherwise + #+ignore (warn "unable to deal intelligently with inlined-NOT not-returns: ~S for ~S from ~S" not-returns not-result-mode (not-values :producer)) (let ((label (make-symbol "not-label"))) @@ -716,7 +717,7 @@ result-mode (car sub-form-result-mode)) as last-form-p = (endp (cdr sub-form)) - ;; do (warn "progn rm: ~S" (car sub-form-result-mode)) + ;; do (warn "progn rm: ~S" (car sub-form-result-mode)) appending (compiler-values-bind (&code code &returns sub-returns-mode &functional-p no-sub-side-effects-p From ffjeld at common-lisp.net Fri Apr 16 14:42:22 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 10:42:22 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9296 Modified Files: inspect.lisp Log Message: Added function malloc-data-words, and some minor edits. Date: Fri Apr 16 10:42:22 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.7 movitz/losp/muerte/inspect.lisp:1.8 --- movitz/losp/muerte/inspect.lisp:1.7 Wed Mar 31 21:11:48 2004 +++ movitz/losp/muerte/inspect.lisp Fri Apr 16 10:42:22 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.7 2004/04/01 02:11:48 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.8 2004/04/16 14:42:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -189,10 +189,9 @@ (structure-object (copy-structure old)))) -(defun malloc-words (words) - (malloc-clumps (1+ (truncate (1+ words) 2)))) - (defun malloc-clumps (clumps) + "Allocate general-purpose memory, i.e. including pointers. +The unit clump is 8 bytes, or two words." (let ((x (with-inline-assembly (:returns :eax :side-effects t) (:compile-form (:result-mode :ebx) clumps) (:shll 1 :ebx) @@ -204,8 +203,15 @@ x)) (defun malloc-data-clumps (clumps) - "Allocate clumps for non-pointer data (i.e. doesn't require initialization)." + "Allocate memory for non-pointer data (i.e. doesn't require initialization)." + ;; Never mind, this is the stupid default implementation. (malloc-clumps clumps)) + +(defun malloc-words (words) + (malloc-clumps (1+ (truncate (1+ words) 2)))) + +(defun malloc-data-words (words) + (malloc-data-clumps (1+ (truncate (1+ words) 2)))) (defun location-in-object-p (object location) "Is location inside object?" From ffjeld at common-lisp.net Fri Apr 16 14:42:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 10:42:52 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2464 Modified Files: arrays.lisp Log Message: Allocate non-pointer memory for arrays specialized to (unsigned-byte 32). Date: Fri Apr 16 10:42:51 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.16 movitz/losp/muerte/arrays.lisp:1.17 --- movitz/losp/muerte/arrays.lisp:1.16 Wed Mar 31 21:09:58 2004 +++ movitz/losp/muerte/arrays.lisp Fri Apr 16 10:42:51 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.16 2004/04/01 02:09:58 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.17 2004/04/16 14:42:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -548,7 +548,7 @@ (replace array initial-contents))) array)) ((member element-type '(u32 (unsigned-byte 32)) :test #'equal) - (let ((array (malloc-words dimensions))) + (let ((array (malloc-data-words dimensions))) (setf (memref array #.(bt:slot-offset 'movitz::movitz-vector 'movitz::flags) 0 :unsigned-byte16) 0) From ffjeld at common-lisp.net Fri Apr 16 14:43:44 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 10:43:44 -0400 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8224 Modified Files: packages.lisp Log Message: Added symbol malloc-data-clumps. Date: Fri Apr 16 10:43:44 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.17 movitz/packages.lisp:1.18 --- movitz/packages.lisp:1.17 Thu Apr 15 15:56:59 2004 +++ movitz/packages.lisp Fri Apr 16 10:43:44 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.17 2004/04/15 19:56:59 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.18 2004/04/16 14:43:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1141,6 +1141,7 @@ #:map-heap-words #:map-stack-words #:malloc-clumps + #:malloc-data-clumps #:malloc-cons-pointer #:malloc-buffer-start From ffjeld at common-lisp.net Fri Apr 16 14:44:42 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 10:44:42 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv28476 Modified Files: los0-gc.lisp Log Message: Added los0-malloc-data-clumps, so that the los0 GC architecture now don't initialize non-pointer memory. Date: Fri Apr 16 10:44:42 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.9 movitz/losp/los0-gc.lisp:1.10 --- movitz/losp/los0-gc.lisp:1.9 Thu Apr 15 11:23:31 2004 +++ movitz/losp/los0-gc.lisp Fri Apr 16 10:44:42 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.9 2004/04/15 15:23:31 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.10 2004/04/16 14:44:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -54,7 +54,7 @@ (defun space-cons-pointer () (aref (%run-time-context-slot 'nursery-space) 0)) -(define-primitive-function new-fast-cons () +(define-primitive-function los0-fast-cons () "Allocate a cons cell from nursery-space." (with-inline-assembly (:returns :eax) retry-cons @@ -72,29 +72,46 @@ (:movl :ecx (:edx 2)) (:ret))) -(defun new-malloc-clumps (clumps) - (check-type clumps (integer 0 1000)) - (with-inline-assembly (:returns :ebx) +(defun los0-malloc-clumps (clumps) + (check-type clumps (integer 0 4000)) + (with-inline-assembly (:returns :eax) retry - (:compile-form (:result-mode :eax) clumps) + (:compile-form (:result-mode :ebx) clumps) (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) (:movl (:edx 2) :ecx) - (:leal (:edx :ecx 8) :ebx) - (:leal ((:eax 2) :ecx) :ecx) - (:cmpl #x3fff4 :ecx) + (:leal ((:ebx 2) :ecx) :eax) + (:cmpl #x3fff4 :eax) (:jge '(:sub-program () (:compile-form (:result-mode :ignore) (stop-and-copy)) (:jmp 'retry))) - (:movl :ecx (:edx 2)) + (:movl :eax (:edx 2)) + (:movl #.(movitz:tag :infant-object) (:edx :ecx 6)) + (:leal (:edx :ecx 8) :eax) (:xorl :ecx :ecx) init-loop ; Now init eax number of clumps. - (:movl :edi (:ebx (:ecx 2) -6)) - (:movl :edi (:ebx (:ecx 2) -2)) + (:movl :edi (:eax (:ecx 2) -6)) + (:movl :edi (:eax (:ecx 2) -2)) (:addl 4 :ecx) - (:cmpl :eax :ecx) - (:jb 'init-loop) - (:movl #.(movitz:tag :infant-object) (:ebx -2)))) + (:cmpl :ebx :ecx) + (:jb 'init-loop))) + +(defun los0-malloc-data-clumps (clumps) + (check-type clumps (integer 0 4000)) + (with-inline-assembly (:returns :eax) + retry + (:compile-form (:result-mode :ebx) clumps) + (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) + (:movl (:edx 2) :ecx) + (:leal ((:ebx 2) :ecx) :eax) + (:cmpl #x3fff4 :eax) + (:jge '(:sub-program () + (:compile-form (:result-mode :ignore) + (stop-and-copy)) + (:jmp 'retry))) + (:movl :eax (:edx 2)) + (:movl #.(movitz:tag :infant-object) (:edx :ecx 6)) + (:leal (:edx :ecx 8) :eax))) (defun los0-handle-out-of-memory (exception interrupt-frame) (declare (ignore exception interrupt-frame)) @@ -104,20 +121,25 @@ (defun install-los0-consing () (setf (%run-time-context-slot 'nursery-space) (allocate-duo-space)) - (let ((conser (symbol-value 'new-fast-cons))) + (setf (exception-handler 113) + (lambda (exception interrupt-frame) + (declare (ignore exception interrupt-frame)) + (format t "~&;; Handling out-of-memory exception..") + (stop-and-copy))) + (let ((conser (symbol-value 'los0-fast-cons))) (check-type conser vector) (setf (%run-time-context-slot 'muerte::fast-cons) conser)) (let ((old-malloc (symbol-function 'muerte:malloc-clumps))) (setf (symbol-function 'muerte:malloc-clumps) - (symbol-function 'new-malloc-clumps)) - (setf (symbol-function 'new-malloc-clumps) + (symbol-function 'los0-malloc-clumps)) + (setf (symbol-function 'los0-malloc-clumps) old-malloc)) - (setf (exception-handler 113) - (lambda (exception interrupt-frame) - (declare (ignore exception interrupt-frame)) - (format t "~&;; Handling out-of-memory exception..") - (stop-and-copy))) + (let ((old-malloc-data (symbol-function 'muerte:malloc-data-clumps))) + (setf (symbol-function 'muerte:malloc-data-clumps) + (symbol-function 'los0-malloc-data-clumps)) + (setf (symbol-function 'los0-malloc-data-clumps) + old-malloc-data)) (values)) (defun install-old-consing () @@ -127,9 +149,14 @@ conser)) (let ((old-malloc (symbol-function 'muerte:malloc-clumps))) (setf (symbol-function 'muerte:malloc-clumps) - (symbol-function 'new-malloc-clumps)) - (setf (symbol-function 'new-malloc-clumps) + (symbol-function 'los0-malloc-clumps)) + (setf (symbol-function 'los0-malloc-clumps) old-malloc)) + (let ((old-malloc-data (symbol-function 'muerte:malloc-data-clumps))) + (setf (symbol-function 'muerte:malloc-data-clumps) + (symbol-function 'los0-malloc-data-clumps)) + (setf (symbol-function 'los0-malloc-data-clumps) + old-malloc-data)) (values)) (defun object-in-space-p (space object) From ffjeld at common-lisp.net Fri Apr 16 18:55:07 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 14:55:07 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7751 Modified Files: basic-macros.lisp Log Message: Added macro define-global-variable. Date: Fri Apr 16 14:55:07 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.10 movitz/losp/muerte/basic-macros.lisp:1.11 --- movitz/losp/muerte/basic-macros.lisp:1.10 Wed Apr 14 17:59:34 2004 +++ movitz/losp/muerte/basic-macros.lisp Fri Apr 16 14:55:07 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.10 2004/04/14 21:59:34 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.11 2004/04/16 18:55:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1040,6 +1040,12 @@ (:je 'boundp-done) (:stc) boundp-done))) + +(defmacro define-global-variable (name init-form &optional docstring) + "A global variable will be accessed by ignoring local bindings." + `(progn + (defparameter ,name ,init-form ,docstring) + (define-symbol-macro ,name (%symbol-global-value ',name)))) (require :muerte/setf) From ffjeld at common-lisp.net Fri Apr 16 19:15:20 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 15:15:20 -0400 Subject: [movitz-cvs] CVS update: movitz/bootblock.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26126 Modified Files: bootblock.lisp Log Message: Removed the video-initialization part of the bootloader, because it shouldn't be needed anymore. Date: Fri Apr 16 15:15:20 2004 Author: ffjeld Index: movitz/bootblock.lisp diff -u movitz/bootblock.lisp:1.7 movitz/bootblock.lisp:1.8 --- movitz/bootblock.lisp:1.7 Thu Apr 15 09:03:16 2004 +++ movitz/bootblock.lisp Fri Apr 16 15:15:20 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:47:19 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: bootblock.lisp,v 1.7 2004/04/15 13:03:16 ffjeld Exp $ +;;;; $Id: bootblock.lisp,v 1.8 2004/04/16 19:15:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -209,17 +209,6 @@ (movw 'entering :si) ; Print welcome message (call 'print) - (:movb #xf :ah) - (:int #x10) ; - (:andb #x7f :al) - (:cmpb #x3 :al) - (:je 'video-ok) - (:movw #x0083 :ax) ; set screen mode - (:int #x10) - (:movb 2 :ah) ; set cursor position - (:int #x10) - video-ok - ;; Read the cursor position into DH (row) and DL (column). (:movb 3 :ah) (:movb 0 :bh) From ffjeld at common-lisp.net Fri Apr 16 19:17:22 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 15:17:22 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/textmode.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv19552 Modified Files: textmode.lisp Log Message: Changed the textmode parameters *screen* etc. to be "global variables". Re-wrote textmode-scroll-down. Various small fixes. Date: Fri Apr 16 15:17:22 2004 Author: ffjeld Index: movitz/losp/x86-pc/textmode.lisp diff -u movitz/losp/x86-pc/textmode.lisp:1.4 movitz/losp/x86-pc/textmode.lisp:1.5 --- movitz/losp/x86-pc/textmode.lisp:1.4 Wed Mar 31 21:15:21 2004 +++ movitz/losp/x86-pc/textmode.lisp Fri Apr 16 15:17:22 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 15:38:56 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: textmode.lisp,v 1.4 2004/04/01 02:15:21 ffjeld Exp $ +;;;; $Id: textmode.lisp,v 1.5 2004/04/16 19:17:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -23,16 +23,24 @@ (in-package muerte.x86-pc) -(defconstant *screen* #xb8000) -(defconstant *screen-width* 80) -(defconstant *screen-height* 24) -(defconstant *screen-stride* 80) - -(defparameter *cursor-x* (rem (vga-cursor-location) 80)) -(defparameter *cursor-y* (truncate (vga-cursor-location) 80)) -(defparameter *color* #x0700) +(define-global-variable *screen* + (vga-memory-map)) -(defparameter *simple-console-state* 'initialized) +(define-global-variable *cursor-x* + (rem (vga-cursor-location) 80)) + +(define-global-variable *cursor-y* + (truncate (vga-cursor-location) 80)) + +(define-global-variable *screen-width* + (vga-horizontal-display-end)) + +(define-global-variable *screen-height* + (truncate (vga-vertical-display-end) + (vga-character-height))) + +(define-global-variable *screen-stride* + (vga-horizontal-display-end)) (defun move-vga-cursor (x y) (let ((dest (+ x (* y *screen-stride*)))) @@ -59,91 +67,75 @@ value) (defun textmode-write-char (c) - (cond - #+ignore - ((and (not (eq 'initialized *simple-console-state*)) - (/= #xabba (memref-int #xb8000 0 0 :unsigned-byte16))) - (setf (memref-int #xb8000 0 0 :unsigned-byte16) #xabba - (memref-int #xb8000 0 1 :unsigned-byte16) 4 - (memref-int #xb8000 0 8 :unsigned-byte8) #x46 ; (char-code c) - (memref-int #xb8000 1 8 :unsigned-byte8) #xe0)) - #+ignore - ((not (eq 'initialized *simple-console-state*)) - (let ((pos (memref-int #xb8000 0 1 :unsigned-byte16))) - (when (< pos (* 80 25 2)) - (setf (memref-int #xb8000 0 (* 2 pos) :unsigned-byte8) (char-code c) - (memref-int #xb8000 1 (* 2 pos) :unsigned-byte8) #xe0 - (memref-int #xb8000 0 1 :unsigned-byte16) (1+ pos))))) - (t (case c - (#\newline - (setf *cursor-x* 0) - (cond - ((= *screen-height* *cursor-y*) - (textmode-scroll-down) - (move-vga-cursor 0 *cursor-y*)) - (t (incf *cursor-y*) - (move-vga-cursor 0 *cursor-y*)))) - (#\backspace - (if (/= 0 *cursor-x*) - (decf *cursor-x*) - (progn - (decf *cursor-y*) - (setf *cursor-x* (1- *screen-width*)))) - (move-vga-cursor *cursor-x* *cursor-y*)) - (#\return - (setf *cursor-x* 0) - (move-vga-cursor 0 *cursor-y*)) - (#\tab - (textmode-write-char #\space) - (do () ((zerop (rem *cursor-x* 8))) - (textmode-write-char #\space))) - (t (let ((x *cursor-x*) - (y *cursor-y*)) - (when (>= x *screen-width*) - (textmode-write-char #\newline) - (setf x *cursor-x* y *cursor-y*)) - (let ((index (+ x (* y *screen-stride*)))) - (setf (memref-int *screen* 0 index :unsigned-byte16 t) - (logior #x0700 (char-code c))) - (move-vga-cursor (setf *cursor-x* (1+ x)) y))))))) + (case c + (#\newline + (setf *cursor-x* 0) + (cond + ((>= (1+ *cursor-y*) *screen-height*) + (textmode-scroll-down) + (setf *cursor-y* (1- *screen-height*))) + (t (incf *cursor-y*))) + (move-vga-cursor 0 *cursor-y*)) + (#\backspace + (if (/= 0 *cursor-x*) + (decf *cursor-x*) + (progn + (decf *cursor-y*) + (setf *cursor-x* (1- *screen-width*)))) + (move-vga-cursor *cursor-x* *cursor-y*)) + (#\return + (setf *cursor-x* 0) + (move-vga-cursor 0 *cursor-y*)) + (#\tab + (textmode-write-char #\space) + (do () ((zerop (rem *cursor-x* 8))) + (textmode-write-char #\space))) + (t (let ((x *cursor-x*) + (y *cursor-y*)) + (when (>= x *screen-width*) + (textmode-write-char #\newline) + (setf x *cursor-x* y *cursor-y*)) + (let ((index (+ x (* y *screen-stride*)))) + (setf (memref-int *screen* 0 index :unsigned-byte16 t) + (logior #x0700 (char-code c))) + (move-vga-cursor (setf *cursor-x* (1+ x)) y))))) nil) +(defun textmode-copy-line (destination source count) + (check-type count (integer 0 511)) + (check-type source (unsigned-byte 20)) + (check-type destination (unsigned-byte 20)) + (with-inline-assembly (:returns :nothing) + (:compile-form (:result-mode :eax) source) + (:compile-form (:result-mode :ebx) destination) + (:compile-form (:result-mode :edx) count) + (:andl #x-16 :eax) + (:andl #x-16 :ebx) + (:andl #x-8 :edx) + (:shrl 2 :eax) + (:shrl 2 :ebx) + (:shrl 1 :edx) + (:jz 'end-copy-loop) + copy-loop + ((:gs-override) :movl (:eax :edx -4) :ecx) + ((:gs-override) :movl :ecx (:ebx :edx -4)) + (:subl 4 :edx) + (:ja 'copy-loop) + end-copy-loop)) + (defun textmode-scroll-down () - "Scroll the console down one line." (declare (special muerte.lib::*scroll-offset*)) (incf muerte.lib::*scroll-offset*) - (with-inline-assembly (:returns :nothing) - (:movl #xb8000 :eax) - (:movl #.(cl:+ #xb8000 160) :ebx) - (:movl #.(cl:* 80 24 1) :ecx) - copy-loop - ((:gs-override) :movw (:ebx) :dx) - ((:gs-override) :movw :dx (:eax)) - (:addl 2 :ebx) - (:addl 2 :eax) - (:subl 1 :ecx) - (:jnz 'copy-loop) - (:movl #.(cl:* 80 1) :ecx) - clear-loop - ((:gs-override) :movw #x0720 (:eax)) - (:addl 2 :eax) - (:subl 1 :ecx) - (:jnz 'clear-loop))) + (loop with stride = (* 2 *screen-stride*) + for y below *screen-height* + as src from (+ *screen* stride) by stride + as dst from *screen* by stride + do (textmode-copy-line dst src *screen-width*))) (defun textmode-clear-line (from-column line) (let ((dest (+ *screen* (* line 80 2) (* from-column 2)))) (dotimes (i (- 80 from-column)) - (setf (memref-int dest 0 i :unsigned-byte16 t) #x0720)) - #+ignore - (with-inline-assembly (:returns :nothing) - (:pushl :edi) - (:compile-form (:result-mode :eax) dest) - (:movl :eax :edi) - (:shrl #.movitz:+movitz-fixnum-shift+ :edi) - (:movl #.(cl:* 80 1) :ecx) - (:movw #x0720 :ax) - ((:repz) :stosw) - (:popl :edi)))) + (setf (memref-int dest 0 i :unsigned-byte16 t) #x0720)))) (defun write-word (word) (let ((dest (+ *screen* (* *cursor-x* 2) (* *cursor-y* 160)))) @@ -220,12 +212,12 @@ "This function can act as *terminal-io* without/before CLOS support." (declare (dynamic-extent args)) (case op + (muerte::stream-write-char + (textmode-write-char (car args))) (muerte::stream-fresh-line (when (plusp (cursor-column)) (textmode-write-char #\Newline) t)) - (muerte::stream-write-char - (textmode-write-char (car args))) (muerte::stream-read-char (loop when (muerte.x86-pc.keyboard:poll-char) return it)) (muerte::stream-read-char-no-hang From ffjeld at common-lisp.net Fri Apr 16 19:17:55 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 15:17:55 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/vga.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv13495 Modified Files: vga.lisp Log Message: Added some VGA register accessors. Date: Fri Apr 16 15:17:55 2004 Author: ffjeld Index: movitz/losp/x86-pc/vga.lisp diff -u movitz/losp/x86-pc/vga.lisp:1.3 movitz/losp/x86-pc/vga.lisp:1.4 --- movitz/losp/x86-pc/vga.lisp:1.3 Mon Jan 19 06:23:52 2004 +++ movitz/losp/x86-pc/vga.lisp Fri Apr 16 15:17:55 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 25 14:08:20 2001 ;;;; -;;;; $Id: vga.lisp,v 1.3 2004/01/19 11:23:52 ffjeld Exp $ +;;;; $Id: vga.lisp,v 1.4 2004/04/16 19:17:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -19,18 +19,18 @@ (in-package muerte.x86-pc) -(defun (setf vga-crt-controller-register) (value register) - (let* ((address-register (if (logbitp 0 (io-port #x3cc :unsigned-byte8)) #x3d4 #x3b4)) - (data-register (1+ address-register))) - (setf (io-port address-register :unsigned-byte8) register - (io-port data-register :unsigned-byte8) value))) - (defun vga-crt-controller-register (register) (let* ((address-register (if (logbitp 0 (io-port #x3cc :unsigned-byte8)) #x3d4 #x3b4)) (data-register (1+ address-register))) (setf (io-port address-register :unsigned-byte8) register) (io-port data-register :unsigned-byte8))) +(defun (setf vga-crt-controller-register) (value register) + (let* ((address-register (if (logbitp 0 (io-port #x3cc :unsigned-byte8)) #x3d4 #x3b4)) + (data-register (1+ address-register))) + (setf (io-port address-register :unsigned-byte8) register + (io-port data-register :unsigned-byte8) value))) + (defun vga-graphics-register (register) (setf (io-port #x3ce :unsigned-byte8) register) (io-port #x3cf :unsigned-byte8)) @@ -60,3 +60,17 @@ (#b01 (values #xa0000 #xaffff)) (#b10 (values #xb0000 #xb7fff)) (#b11 (values #xb8000 #xbffff)))) + +(defun vga-horizontal-display-end () + (1+ (vga-crt-controller-register 1))) + +(defun vga-vertical-display-end () + (let ((overflow (vga-crt-controller-register 7))) + (+ 1 + (vga-crt-controller-register #x12) + (if (logbitp 1 overflow) #x100 0) + (if (logbitp 6 overflow) #x200 0)))) + +(defun vga-character-height () + (1+ (ldb (byte 5 0) + (vga-crt-controller-register 9)))) From ffjeld at common-lisp.net Fri Apr 16 19:20:47 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 15:20:47 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv19582 Modified Files: compiler.lisp Log Message: Fixed a nasty compiler bug that would let two function parameters be assigned to the same register. By some weird accident this bug didn't seem to do much actual harm, but the potential was certainly there. Date: Fri Apr 16 15:20:46 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.48 movitz/compiler.lisp:1.49 --- movitz/compiler.lisp:1.48 Thu Apr 15 15:58:20 2004 +++ movitz/compiler.lisp Fri Apr 16 15:20:46 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.48 2004/04/15 19:58:20 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.49 2004/04/16 19:20:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2451,11 +2451,13 @@ (destructuring-bind (binding &key init-with-register init-with-type protect-registers protect-carry) (cdr i) - (declare (ignore binding protect-carry init-with-type)) + (declare (ignore protect-carry init-with-type)) (when init-with-register (setf free-so-far (remove-if (lambda (x) - (or (eq x init-with-register) - (member x protect-registers))) + (if (new-binding-located-p binding frame-map) + (eq x (new-binding-location binding frame-map)) + (or (eq x init-with-register) + (member x protect-registers)))) free-so-far))))) (t (case (instruction-is i) ((nil :call) @@ -2476,8 +2478,7 @@ (remove-if (lambda (r) (tree-search i r)) free-so-far))) - ((:load-constant :load-lexical :store-lexical :init-lexvar - :cons-get :endp :incf-lexvar) + ((:load-constant :load-lexical :store-lexical :cons-get :endp :incf-lexvar :init-lexvar) (assert (gethash (instruction-is i) *extended-code-expanders*)) (unless (can-expand-extended-p i frame-map) (return (values nil t))) @@ -3764,6 +3765,9 @@ (and (edx-var env) (new-binding-location (edx-var env) frame-map :default nil)))) ;; (warn "l0: ~S, l1: ~S" location-0 location-1) + (assert (not (and location-0 + (eql location-0 location-1))) () + "Compiler bug: two bindings in same location.") (cond ((and (eq :ebx location-0) (eq :eax location-1)) `((:xchgl :eax :ebx))) From ffjeld at common-lisp.net Fri Apr 16 19:21:13 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 15:21:13 -0400 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11392 Modified Files: packages.lisp Log Message: More symbols. Date: Fri Apr 16 15:21:13 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.18 movitz/packages.lisp:1.19 --- movitz/packages.lisp:1.18 Fri Apr 16 10:43:44 2004 +++ movitz/packages.lisp Fri Apr 16 15:21:13 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.18 2004/04/16 14:43:44 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.19 2004/04/16 19:21:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1149,6 +1149,9 @@ #:%run-time-context-slot #:shallow-copy + #:%symbol-global-value + #:define-global-variable + vector-element-type vector-element-size with-subvector-accessor @@ -1303,7 +1306,9 @@ #:code-vector%3op #:code-vector-word #:lu32 - + + #:+movitz-most-positive-fixnum+ + #:+movitz-most-negative-fixnum+ #:+movitz-fixnum-factor+ #:+movitz-fixnum-shift+ #:+movitz-fixnum-zmask+ From ffjeld at common-lisp.net Fri Apr 16 19:21:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 15:21:52 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/eval.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9718 Modified Files: eval.lisp Log Message: We can use symbol-value to evaluate constant variables, I believe. Date: Fri Apr 16 15:21:51 2004 Author: ffjeld Index: movitz/losp/muerte/eval.lisp diff -u movitz/losp/muerte/eval.lisp:1.6 movitz/losp/muerte/eval.lisp:1.7 --- movitz/losp/muerte/eval.lisp:1.6 Thu Apr 15 09:16:28 2004 +++ movitz/losp/muerte/eval.lisp Fri Apr 16 15:21:51 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.6 2004/04/15 13:16:28 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.7 2004/04/16 19:21:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -49,7 +49,7 @@ (defun eval-symbol (form env) "3.1.2.1.1 Symbols as Forms" (if (symbol-constant-variable-p form) - (symbol-global-value form) + (symbol-value form) (let ((binding (env-binding env form))) (or (and binding (cdr binding)) (symbol-value form))))) From ffjeld at common-lisp.net Fri Apr 16 19:22:21 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 15:22:21 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1445 Modified Files: integers.lisp Log Message: Minor typo. Date: Fri Apr 16 15:22:21 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.6 movitz/losp/muerte/integers.lisp:1.7 --- movitz/losp/muerte/integers.lisp:1.6 Thu Apr 15 09:10:37 2004 +++ movitz/losp/muerte/integers.lisp Fri Apr 16 15:22:21 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.6 2004/04/15 13:10:37 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.7 2004/04/16 19:22:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1088,7 +1088,7 @@ '(integer 0)) ((typep size '(integer 1 *)) (list 'integer 0 (1- (ash 1 size)))) - (t (error "Illegal size for signed-byte.")))) + (t (error "Illegal size for unsigned-byte.")))) (define-simple-typep (bit bitp) (x) (or (eq x 0) (eq x 1))) From ffjeld at common-lisp.net Fri Apr 16 19:23:23 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 15:23:23 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17516 Modified Files: symbols.lisp Log Message: Removed function symbol-global-value, added macro %symbol-global-value. Date: Fri Apr 16 15:23:23 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.8 movitz/losp/muerte/symbols.lisp:1.9 --- movitz/losp/muerte/symbols.lisp:1.8 Wed Apr 14 16:03:38 2004 +++ movitz/losp/muerte/symbols.lisp Fri Apr 16 15:23:23 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.8 2004/04/14 20:03:38 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.9 2004/04/16 19:23:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,13 +56,8 @@ (defun set (symbol value) (setf (symbol-value symbol) value)) -(defun symbol-global-value (symbol) - (if symbol - (let ((x (movitz-accessor symbol movitz-symbol value))) - (if (eq x (load-global-constant unbound-value)) - (error 'unbound-value :name symbol) - x)) - nil)) +(defmacro %symbol-global-value (symbol) + `(memref ,symbol ,(bt:slot-offset 'movitz:movitz-symbol 'movitz::value) 0 :lisp)) (defun symbol-function (symbol) (let ((function-value From ffjeld at common-lisp.net Fri Apr 16 19:24:21 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 15:24:21 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8308 Modified Files: symbols.lisp Log Message: Make %symbol-global-value a function, of course. Date: Fri Apr 16 15:24:20 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.9 movitz/losp/muerte/symbols.lisp:1.10 --- movitz/losp/muerte/symbols.lisp:1.9 Fri Apr 16 15:23:23 2004 +++ movitz/losp/muerte/symbols.lisp Fri Apr 16 15:24:20 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.9 2004/04/16 19:23:23 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.10 2004/04/16 19:24:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,8 +56,11 @@ (defun set (symbol value) (setf (symbol-value symbol) value)) -(defmacro %symbol-global-value (symbol) +(define-compiler-macro %symbol-global-value (symbol) `(memref ,symbol ,(bt:slot-offset 'movitz:movitz-symbol 'movitz::value) 0 :lisp)) + +(defun %symbol-global-value (symbol) + (%symbol-global-value symbol)) (defun symbol-function (symbol) (let ((function-value From ffjeld at common-lisp.net Fri Apr 16 19:25:07 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 15:25:07 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9750 Modified Files: basic-functions.lisp Log Message: Re-wrote the check-type macro somewhat. It should require less code-size now. Date: Fri Apr 16 15:25:06 2004 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.10 movitz/losp/muerte/basic-functions.lisp:1.11 --- movitz/losp/muerte/basic-functions.lisp:1.10 Tue Apr 6 20:20:12 2004 +++ movitz/losp/muerte/basic-functions.lisp Fri Apr 16 15:25:06 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.10 2004/04/07 00:20:12 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.11 2004/04/16 19:25:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -369,5 +369,12 @@ (defun %word-offset (word offset) (%word-offset word offset)) - - +(defun check-type-failed (value type &optional place-name type-description) + (cond + ((and place-name type-description) + (error "The value of ~S, ~S, is not ~A." + place-name value type-description)) + (place-name + (error "The value of ~S, ~S, is not of type ~S." + place-name value type)) + (t (error "~S is not of type ~S." value type)))) \ No newline at end of file From ffjeld at common-lisp.net Fri Apr 16 19:25:12 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 15:25:12 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12854 Modified Files: basic-macros.lisp Log Message: Re-wrote the check-type macro somewhat. It should require less code-size now. Date: Fri Apr 16 15:25:12 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.11 movitz/losp/muerte/basic-macros.lisp:1.12 --- movitz/losp/muerte/basic-macros.lisp:1.11 Fri Apr 16 14:55:07 2004 +++ movitz/losp/muerte/basic-macros.lisp Fri Apr 16 15:25:11 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.11 2004/04/16 18:55:07 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.12 2004/04/16 19:25:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -520,13 +520,15 @@ `((:movw ,(dpb wide-other-tag (byte 8 8) (movitz::tag other-tag)) (:eax -2)))))) (defmacro check-type (place type &optional type-string) - (declare (ignore type-string)) - `(let ((place-value ,place)) - (unless (typep place-value ',type) - (error "Place ~A is not of type ~A, its value is {~Z}." - ',place ',type place-value)))) + (if (not (stringp type-string)) + `(let ((place-value ,place)) + (unless (typep place-value ',type) + (check-type-failed place-value ',type ',place))) + `(let ((place-value ,place)) + (unless (typep place-value ',type) + (check-type-failed place-value ',type ',place ,type-string))))) -(define-compiler-macro check-type (place type &optional type-string &environment env) +(define-compiler-macro check-type (&whole form place type &optional type-string &environment env) (declare (ignore type-string)) (cond ((movitz:movitz-constantp place env) @@ -538,10 +540,7 @@ `(unless (typep ,place ',type) (with-inline-assembly (:returns :non-local-exit) (:int 66))) - `(let ((place-value ,place)) - (unless (typep place-value ',type) - (error "Place ~A is not of type ~A, its value is ~Z." - ',place ',type place-value))))))) + form)))) (defmacro assert (test-form &optional places datum-form &rest argument-forms) (declare (ignore places)) From ffjeld at common-lisp.net Fri Apr 16 23:33:36 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 19:33:36 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29476 Modified Files: basic-macros.lisp Log Message: Make define-compile-time-variable behave more like defvar than defparameter. Date: Fri Apr 16 19:33:36 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.12 movitz/losp/muerte/basic-macros.lisp:1.13 --- movitz/losp/muerte/basic-macros.lisp:1.12 Fri Apr 16 15:25:11 2004 +++ movitz/losp/muerte/basic-macros.lisp Fri Apr 16 19:33:36 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.12 2004/04/16 19:25:11 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.13 2004/04/16 23:33:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -138,9 +138,11 @@ (let ((the-value (eval value))) `(progn (eval-when (:compile-toplevel) - (defparameter ,name ',the-value) - (pushnew ',name (movitz::image-compile-time-variables movitz::*image*))) - (defparameter ,name ',the-value)))) + (defvar ,name) + (unless (member ',name (movitz::image-compile-time-variables movitz::*image*)) + (setf ,name ',the-value) + (push ',name (movitz::image-compile-time-variables movitz::*image*)))) + (defvar ,name 'uninitialized-compile-time-variable)))) (defmacro let* (var-list &body body) (labels ((expand (rest-vars body) From ffjeld at common-lisp.net Fri Apr 16 23:34:43 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 19:34:43 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv20384 Modified Files: typep.lisp Log Message: Made typep considerably smarter about the integer type. Date: Fri Apr 16 19:34:43 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.6 movitz/losp/muerte/typep.lisp:1.7 --- movitz/losp/muerte/typep.lisp:1.6 Tue Apr 6 20:17:19 2004 +++ movitz/losp/muerte/typep.lisp Fri Apr 16 19:34:43 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.6 2004/04/07 00:17:19 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.7 2004/04/16 23:34:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -239,17 +239,70 @@ (when deriver-function `(typep ,object ',(funcall deriver-function))))))) ((consp type) - (case (car type) - ((not) - (assert (and (cadr type) (not (cddr type)))) - `(not (typep ,object ',(cadr type)))) - ((or and) - `(let ((typep-object ,object)) - (,(car type) - ,@(loop for subtype in (cdr type) - collect `(typep ,object ',subtype))))) - ((not and or) - (warn "typep compilermacro: ~S" type))))) + (let ((deriver-function (gethash (car type) *compiler-derived-typespecs*))) + (if deriver-function + `(typep ,object ',(apply deriver-function (cdr type))) + (case (car type) + ((integer) + (destructuring-bind (&optional (lower-limit '*) (upper-limit '*)) + (cdr type) + (let* ((min movitz:+movitz-most-negative-fixnum+) + (max movitz:+movitz-most-positive-fixnum+) + (lower-limit (if (eq lower-limit '*) min lower-limit)) + (upper-limit (if (eq upper-limit '*) max upper-limit))) + (assert (<= lower-limit upper-limit) () + "The lower limit of an integer type must be smaller than the upper limit.") + (cond + ((and (= lower-limit min) (= upper-limit max)) + `(typep ,object 'integer)) + ((= lower-limit upper-limit) + `(eql ,object ,lower-limit)) + ((and (= lower-limit 0) + (= 1 (logcount (1+ upper-limit)))) + `(with-inline-assembly (:returns :boolean-zf=1) + (:compile-form (:result-mode :eax) ,object) + (:testl ,(logxor #xffffffff + (* movitz:+movitz-fixnum-factor+ upper-limit)) + :eax))) + ((= 1 (logcount (1+ (- upper-limit lower-limit)))) + `(with-inline-assembly (:returns :boolean-zf=1) + (:compile-form (:result-mode :eax) ,object) + (:leal (:eax ,(* movitz:+movitz-fixnum-factor+ + (- lower-limit))) + :ecx) + (:testl ,(logxor #xffffffff + (* movitz:+movitz-fixnum-factor+ + (- upper-limit lower-limit))) + :ecx))) + ((= lower-limit 0) + `(with-inline-assembly-case () + (do-case (t :boolean-cf=1 :labels (not-fixnum)) + (:compile-form (:result-mode :eax) ,object) + (:testb ,movitz:+movitz-fixnum-zmask+ :al) ; CF<=0 + (:jnz 'not-fixnum) + (:cmpl ,(* (1+ upper-limit) movitz:+movitz-fixnum-factor+) + :eax) + not-fixnum))) + (t `(with-inline-assembly-case () + (do-case (t :boolean-cf=1 :labels (not-fixnum)) + (:compile-form (:result-mode :eax) ,object) + (:testb ,movitz:+movitz-fixnum-zmask+ :al) ; CF<=0 + (:jnz 'not-fixnum) + (:subl ,(* lower-limit movitz:+movitz-fixnum-factor+) :eax) + (:cmpl ,(* (- upper-limit lower-limit -1) + movitz:+movitz-fixnum-factor+) + :eax) + not-fixnum))))))) + ((not) + (assert (and (cadr type) (not (cddr type)))) + `(not (typep ,object ',(cadr type)))) + ((or and) + `(let ((typep-object ,object)) + (,(car type) + ,@(loop for subtype in (cdr type) + collect `(typep ,object ',subtype))))) + ((not and or) + (warn "typep compilermacro: ~S" type))))))) form))))) (defmacro define-typep (tname lambda &body body) From ffjeld at common-lisp.net Fri Apr 16 23:35:30 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 19:35:30 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24308 Modified Files: primitive-functions.lisp Log Message: Minor edits. Date: Fri Apr 16 19:35:29 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.12 movitz/losp/muerte/primitive-functions.lisp:1.13 --- movitz/losp/muerte/primitive-functions.lisp:1.12 Thu Apr 15 09:07:24 2004 +++ movitz/losp/muerte/primitive-functions.lisp Fri Apr 16 19:35:29 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.12 2004/04/15 13:07:24 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.13 2004/04/16 23:35:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -601,8 +601,6 @@ (find-class (structure-object-name object))) (character (find-class 'character)) - (basic-restart - (find-class 'basic-restart)) (run-time-context (find-class 'run-time-context)) (null @@ -613,6 +611,8 @@ (find-class 'symbol)) (fixnum (find-class 'fixnum)) + (basic-restart + (find-class 'basic-restart)) (tag6 (error "Don't know the class of ~Z with other-type #x~X." object (with-inline-assembly (:returns :untagged-fixnum-ecx) From ffjeld at common-lisp.net Fri Apr 16 23:36:40 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 19:36:40 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9968 Modified Files: symbols.lisp Log Message: Added (setf %symbol-global-value). Date: Fri Apr 16 19:36:40 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.10 movitz/losp/muerte/symbols.lisp:1.11 --- movitz/losp/muerte/symbols.lisp:1.10 Fri Apr 16 15:24:20 2004 +++ movitz/losp/muerte/symbols.lisp Fri Apr 16 19:36:40 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.10 2004/04/16 19:24:20 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.11 2004/04/16 23:36:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -61,6 +61,13 @@ (defun %symbol-global-value (symbol) (%symbol-global-value symbol)) + +(define-compiler-macro (setf %symbol-global-value) (value symbol) + `(setf (memref ,symbol ,(bt:slot-offset 'movitz:movitz-symbol 'movitz::value) 0 :lisp) + ,value)) + +(defun (setf %symbol-global-value) (value symbol) + (setf (%symbol-global-value symbol) value)) (defun symbol-function (symbol) (let ((function-value From ffjeld at common-lisp.net Fri Apr 16 23:38:42 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 19:38:42 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv25822 Modified Files: compiler.lisp Log Message: Removed some dead code. Date: Fri Apr 16 19:38:41 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.49 movitz/compiler.lisp:1.50 --- movitz/compiler.lisp:1.49 Fri Apr 16 15:20:46 2004 +++ movitz/compiler.lisp Fri Apr 16 19:38:41 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.49 2004/04/16 19:20:46 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.50 2004/04/16 23:38:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5222,25 +5222,9 @@ ((typep binding 'symbol-macro-binding) (compiler-call #'compile-form-unprotected :forward all - :form (funcall *movitz-macroexpand-hook* (macro-binding-expander (movitz-binding form env)) form env))) + :form (funcall *movitz-macroexpand-hook* + (macro-binding-expander (movitz-binding form env)) form env))) (t (compiler-call #'compile-dynamic-variable :forward all)))))) - -#+old-compiler -(defun ensure-local-binding (binding funobj env) - "Make sure that we have a binding that is local to funobj." - (if (eq funobj (binding-funobj binding)) - binding - (let* ((function-env (find-function-env env funobj)) - (local-binding (make-instance - (ecase (function-env-extent function-env) - (:indefinite-extent 'indefinite-borrowed-binding) - ;; XXXX - (:dynamic-extent 'indefinite-borrowed-binding) - (:lexical-extent 'lexical-borrowed-binding)) - :name (binding-name binding) - :target-binding binding))) - (movitz-environment-add-binding function-env (binding-name binding) local-binding) - local-binding))) (define-compiler compile-lexical-variable (&form variable &result-mode result-mode &env env) (let ((binding (movitz-binding variable env))) From ffjeld at common-lisp.net Sat Apr 17 00:02:53 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 20:02:53 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24866 Modified Files: typep.lisp Log Message: Teach typep about the eql and cons types. Date: Fri Apr 16 20:02:53 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.7 movitz/losp/muerte/typep.lisp:1.8 --- movitz/losp/muerte/typep.lisp:1.7 Fri Apr 16 19:34:43 2004 +++ movitz/losp/muerte/typep.lisp Fri Apr 16 20:02:53 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.7 2004/04/16 23:34:43 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.8 2004/04/17 00:02:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -293,6 +293,17 @@ movitz:+movitz-fixnum-factor+) :eax) not-fixnum))))))) + ((eql) + `(eql ,object ',(cadr type))) + ((cons) + (destructuring-bind (&optional (car t) (cdr t)) + (cdr type) + (let ((car (if (eq car '*) t car)) + (cdr (if (eq cdr '*) t cdr))) + `(let ((typep-object ,object)) + (and (typep typep-object 'cons) + (typep (car typep-object) ',car) + (typep (cdr typep-object) ',cdr)))))) ((not) (assert (and (cadr type) (not (cddr type)))) `(not (typep ,object ',(cadr type)))) @@ -301,9 +312,12 @@ (,(car type) ,@(loop for subtype in (cdr type) collect `(typep ,object ',subtype))))) - ((not and or) - (warn "typep compilermacro: ~S" type))))))) + (t (warn "typep ~A" type))))))) form))))) + +#+ignore +(defun foo (x) + (typep x '(cons * symbol))) (defmacro define-typep (tname lambda &body body) (let ((fname (format nil "~A-~A" 'typep tname))) From ffjeld at common-lisp.net Sat Apr 17 00:24:01 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 16 Apr 2004 20:24:01 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3360 Modified Files: typep.lisp Log Message: Minor fix. Date: Fri Apr 16 20:24:00 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.8 movitz/losp/muerte/typep.lisp:1.9 --- movitz/losp/muerte/typep.lisp:1.8 Fri Apr 16 20:02:53 2004 +++ movitz/losp/muerte/typep.lisp Fri Apr 16 20:24:00 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.8 2004/04/17 00:02:53 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.9 2004/04/17 00:24:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -266,9 +266,8 @@ :eax))) ((= 1 (logcount (1+ (- upper-limit lower-limit)))) `(with-inline-assembly (:returns :boolean-zf=1) - (:compile-form (:result-mode :eax) ,object) - (:leal (:eax ,(* movitz:+movitz-fixnum-factor+ - (- lower-limit))) + (:compile-form (:result-mode :ecx) ,object) + (:subl ,(* movitz:+movitz-fixnum-factor+ lower-limit) :ecx) (:testl ,(logxor #xffffffff (* movitz:+movitz-fixnum-factor+ From ffjeld at common-lisp.net Sat Apr 17 14:08:24 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 17 Apr 2004 10:08:24 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27234 Modified Files: typep.lisp Log Message: Tiny edit. Date: Sat Apr 17 10:08:24 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.9 movitz/losp/muerte/typep.lisp:1.10 --- movitz/losp/muerte/typep.lisp:1.9 Fri Apr 16 20:24:00 2004 +++ movitz/losp/muerte/typep.lisp Sat Apr 17 10:08:24 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.9 2004/04/17 00:24:00 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.10 2004/04/17 14:08:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -311,7 +311,7 @@ (,(car type) ,@(loop for subtype in (cdr type) collect `(typep ,object ',subtype))))) - (t (warn "typep ~A" type))))))) + (t (warn "compiling typep ~A" type))))))) form))))) #+ignore From ffjeld at common-lisp.net Sat Apr 17 14:09:07 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 17 Apr 2004 10:09:07 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv4168 Modified Files: inspect.lisp Log Message: The function check-stack-limit certainly doesn't need to also implicitly check the stack-limit. Date: Sat Apr 17 10:09:07 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.8 movitz/losp/muerte/inspect.lisp:1.9 --- movitz/losp/muerte/inspect.lisp:1.8 Fri Apr 16 10:42:22 2004 +++ movitz/losp/muerte/inspect.lisp Sat Apr 17 10:09:07 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.8 2004/04/16 14:42:22 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.9 2004/04/17 14:09:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -24,6 +24,7 @@ (:locally (:bound (:edi (:edi-offset stack-bottom)) :esp)))) (defun check-stack-limit () + (declare (without-check-stack-limit)) ; we do it explicitly.. (check-stack-limit)) (defun stack-top () From ffjeld at common-lisp.net Sat Apr 17 14:10:03 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 17 Apr 2004 10:10:03 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv9897 Modified Files: compiler.lisp Log Message: Be slightly more clever about when to implicitly insert stack-limit-checks. Date: Sat Apr 17 10:10:01 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.50 movitz/compiler.lisp:1.51 --- movitz/compiler.lisp:1.50 Fri Apr 16 19:38:41 2004 +++ movitz/compiler.lisp Sat Apr 17 10:10:00 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.50 2004/04/16 23:38:41 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.51 2004/04/17 14:10:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -728,7 +728,9 @@ (multiple-value-bind (prelude-code have-normalized-ecx-p) (make-compiled-function-prelude stack-frame-size function-env use-stack-frame-p (need-normalized-ecx-p function-env) frame-map - :do-check-stack-p t) + :do-check-stack-p (or (<= 32 stack-frame-size) + (tree-search resolved-code + '(:call)))) (let ((function-code (install-arg-cmp (append prelude-code resolved-code @@ -2702,7 +2704,8 @@ (truncate (or (position-if (lambda (i) (member b (find-read-bindings i))) - (cdr init-pc)) + (cdr init-pc) + #-sbcl :end #-sbcl 10) 15) count))))))))) ;; First, make several passes while trying to locate bindings From ffjeld at common-lisp.net Sat Apr 17 14:10:51 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 17 Apr 2004 10:10:51 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10477 Modified Files: compiler.lisp Log Message: Tiny edit. Date: Sat Apr 17 10:10:51 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.51 movitz/compiler.lisp:1.52 --- movitz/compiler.lisp:1.51 Sat Apr 17 10:10:00 2004 +++ movitz/compiler.lisp Sat Apr 17 10:10:51 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.51 2004/04/17 14:10:00 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.52 2004/04/17 14:10:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -739,11 +739,12 @@ have-normalized-ecx-p))) (let ((optimized-function-code (optimize-code function-code - :keep-labels (append (subseq (movitz-funobj-const-list funobj) - 0 (movitz-funobj-num-jumpers funobj)) - '(entry%1op - entry%2op - entry%3op))))) + :keep-labels (append + (subseq (movitz-funobj-const-list funobj) + 0 (movitz-funobj-num-jumpers funobj)) + '(entry%1op + entry%2op + entry%3op))))) (cons numargs optimized-function-code)))))))) (let ((code1 (cdr (assoc 1 code-specs))) (code2 (cdr (assoc 2 code-specs))) From ffjeld at common-lisp.net Sat Apr 17 15:33:45 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 17 Apr 2004 11:33:45 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv14930 Modified Files: compiler.lisp Log Message: Added "fast" implementations of cddr and cdddr, in an effort to reduce cal/ret run-time and code-size overhead in list processing. Date: Sat Apr 17 11:33:45 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.52 movitz/compiler.lisp:1.53 --- movitz/compiler.lisp:1.52 Sat Apr 17 10:10:51 2004 +++ movitz/compiler.lisp Sat Apr 17 11:33:45 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.52 2004/04/17 14:10:51 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.53 2004/04/17 15:33:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2054,6 +2054,17 @@ (setq p `((:call (:edi ,(global-constant-offset newf)))) next-pc (nthcdr 2 pc)) (explain nil "Changed [~S ~S] to ~S" i i2 newf))) + ((and (global-funcall-p i '(fast-cdr)) + (global-funcall-p i2 '(fast-cdr)) + (global-funcall-p i3 '(fast-cdr))) + (setq p `((:call (:edi ,(global-constant-offset 'fast-cdddr)))) + next-pc (nthcdr 3 pc)) + (explain nil "Changed (cdr (cdr (cdr :eax))) to (cdddr :eax).")) + ((and (global-funcall-p i '(fast-cdr)) + (global-funcall-p i2 '(fast-cdr))) + (setq p `((:call (:edi ,(global-constant-offset 'fast-cddr)))) + next-pc (nthcdr 2 pc)) + (explain nil "Changed (cdr (cdr :eax)) to (cddr :eax).")) ((and (load-stack-frame-p i) (eq :eax (twop-dst i)) (global-funcall-p i2 '(fast-car fast-cdr)) (preserves-stack-location-p i3 (load-stack-frame-p i)) From ffjeld at common-lisp.net Sat Apr 17 15:33:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 17 Apr 2004 11:33:52 -0400 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv21184 Modified Files: image.lisp Log Message: Added "fast" implementations of cddr and cdddr, in an effort to reduce cal/ret run-time and code-size overhead in list processing. Date: Sat Apr 17 11:33:51 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.24 movitz/image.lisp:1.25 --- movitz/image.lisp:1.24 Fri Apr 16 04:57:29 2004 +++ movitz/image.lisp Sat Apr 17 11:33:51 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.24 2004/04/16 08:57:29 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.25 2004/04/17 15:33:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -39,6 +39,18 @@ :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) + (fast-cddr + :binary-type code-vector-word + :initform nil + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (fast-cdddr + :binary-type code-vector-word + :initform nil + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) (fast-car-ebx :binary-type code-vector-word :initform nil @@ -128,12 +140,6 @@ (stack-top ; stack-top must be right after stack-bottom :binary-type word ; in order for the bound instruction to work. :initform #x100000) - (bochs-flags - :binary-type lu32 - :initform 0) - (bochs-flags2 - :binary-type lu32 - :initform 0) ;; (unbound-value :binary-type word @@ -421,6 +427,9 @@ (segment-descriptor-7 :binary-type segment-descriptor :initform (make-segment-descriptor)) + (bochs-flags + :binary-type lu32 + :initform 0) ) (:slot-align null-cons -1)) From ffjeld at common-lisp.net Sat Apr 17 15:33:57 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 17 Apr 2004 11:33:57 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25835 Modified Files: basic-macros.lisp Log Message: Added "fast" implementations of cddr and cdddr, in an effort to reduce cal/ret run-time and code-size overhead in list processing. Date: Sat Apr 17 11:33:57 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.13 movitz/losp/muerte/basic-macros.lisp:1.14 --- movitz/losp/muerte/basic-macros.lisp:1.13 Fri Apr 16 19:33:36 2004 +++ movitz/losp/muerte/basic-macros.lisp Sat Apr 17 11:33:57 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.13 2004/04/16 23:33:36 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.14 2004/04/17 15:33:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -575,6 +575,23 @@ (define-compiler-macro cddr (x) `(cdr (cdr ,x))) +(define-compiler-macro caddr (x) + `(car (cdr (cdr ,x)))) + +(define-compiler-macro cadddr (x) + `(car (cdr (cdr (cdr ,x))))) + +(define-compiler-macro cdar (x) + `(cdr (car ,x))) + + +(define-compiler-macro rest (x) `(cdr ,x)) +(define-compiler-macro first (x) `(car ,x)) +(define-compiler-macro second (x) `(cadr ,x)) +(define-compiler-macro third (x) `(caddr ,x)) +(define-compiler-macro fourth (x) `(cadddr ,x)) +(define-compiler-macro fifth (x) `(caddddr ,x)) + (define-compiler-macro (setf car) (value cell &environment env) (if (and (movitz:movitz-constantp value env) (eq nil (movitz::eval-form value env))) @@ -840,32 +857,6 @@ (array (error "Array backquote not implemented.")) (t (list 'quote form)))) - -;;;(defmacro defun+movitz (name &rest args) -;;; (flet ((make-compile-side-name (x) -;;; (if (find-symbol (symbol-name x) :common-lisp) -;;; (intern (format nil "~A-~A" '#:movitz x)) -;;; x))) -;;; (if (symbolp name) -;;; `(progn -;;; (eval-when (:compile-toplevel) -;;; (defun ,(make-compile-side-name name) , at args)) -;;; (defun ,name , at args)) -;;; `(progn -;;; (eval-when (:compile-toplevel) -;;; (defun (,(first name) ,(make-compile-side-name (second name))) ,@(cddr name) -;;; , at args)) -;;; (defun ,name , at args))))) - - -(define-compiler-macro first (x) - `(car ,x)) -(define-compiler-macro second (x) - `(cadr ,x)) -(define-compiler-macro third (x) - `(caddr ,x)) -(define-compiler-macro rest (x) - `(cdr ,x)) (define-compiler-macro find-class (&whole form &environment env symbol &optional (errorp t)) (declare (ignore errorp)) From ffjeld at common-lisp.net Sat Apr 17 15:34:04 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 17 Apr 2004 11:34:04 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cons.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv2725 Modified Files: cons.lisp Log Message: Added "fast" implementations of cddr and cdddr, in an effort to reduce cal/ret run-time and code-size overhead in list processing. Date: Sat Apr 17 11:34:03 2004 Author: ffjeld Index: movitz/losp/muerte/cons.lisp diff -u movitz/losp/muerte/cons.lisp:1.3 movitz/losp/muerte/cons.lisp:1.4 --- movitz/losp/muerte/cons.lisp:1.3 Mon Mar 22 09:42:31 2004 +++ movitz/losp/muerte/cons.lisp Sat Apr 17 11:34:03 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 15:25:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: cons.lisp,v 1.3 2004/03/22 14:42:31 ffjeld Exp $ +;;;; $Id: cons.lisp,v 1.4 2004/04/17 15:34:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -53,6 +53,36 @@ (:leal (:eax -1) :ecx) (:testb 3 :cl) (:jnz '(:sub-program () (:int 66))) + (:movl (:eax 3) :eax) + (:ret))) + +(define-primitive-function fast-cddr () + "This is the actual CDR code." + (with-inline-assembly (:returns :eax) + (:leal (:eax -1) :ecx) + (:testb 3 :cl) + (:jnz '(:sub-program () (:int 66))) + (:movl (:eax 3) :eax) + (:leal (:eax -1) :ecx) + (:testb 3 :cl) + (:jnz '(:sub-program () (:int 66))) + (:movl (:eax 3) :eax) + (:ret))) + +(define-primitive-function fast-cdddr () + "This is the actual CDR code." + (with-inline-assembly (:returns :eax) + (:leal (:eax -1) :ecx) + (:testb 3 :cl) + (:jnz '(:sub-program (not-cons) (:int 66))) + (:movl (:eax 3) :eax) + (:leal (:eax -1) :ecx) + (:testb 3 :cl) + (:jnz '(:sub-program (not-cons) (:int 66))) + (:movl (:eax 3) :eax) + (:leal (:eax -1) :ecx) + (:testb 3 :cl) + (:jnz '(:sub-program (not-cons) (:int 66))) (:movl (:eax 3) :eax) (:ret))) From ffjeld at common-lisp.net Sun Apr 18 12:32:57 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 18 Apr 2004 08:32:57 -0400 Subject: [movitz-cvs] CVS update: movitz/web-update.sh Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv3081 Added Files: web-update.sh Log Message: *** empty log message *** Date: Sun Apr 18 08:32:57 2004 Author: ffjeld From ffjeld at common-lisp.net Sun Apr 18 12:33:11 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 18 Apr 2004 08:33:11 -0400 Subject: [movitz-cvs] CVS update: movitz/doc/ChangeLog Message-ID: Update of /project/movitz/cvsroot/movitz/doc In directory common-lisp.net:/tmp/cvs-serv11313 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sun Apr 18 08:33:10 2004 Author: ffjeld Index: movitz/doc/ChangeLog diff -u movitz/doc/ChangeLog:1.3 movitz/doc/ChangeLog:1.4 --- movitz/doc/ChangeLog:1.3 Mon Mar 29 10:26:39 2004 +++ movitz/doc/ChangeLog Sun Apr 18 08:33:10 2004 @@ -1,3 +1,17 @@ +2004-04-18 Frode Vatvedt Fjeld + + * The bootloader no longer initializes the VGA subssystem, since + the textmode driver in los0 should be able to adapt to most + standard VGA textmodes now. + + * Apropos should work again, I think it didn't before due to a + compiler bug. + + * There is now a fairly complete GC in los0, meaning in principle + there us no reason it should not keep running forever. I've had an + uptime of about a week. The new-space buffer is limited to 256 KB, + however. + 2004-03-29 Frode Vatvedt Fjeld * Added basic GC functionality. The Movitz platform is now I From ffjeld at common-lisp.net Sun Apr 18 21:27:38 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 18 Apr 2004 17:27:38 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16480 Modified Files: basic-macros.lisp Log Message: Small changes to eq compiler-macro. Date: Sun Apr 18 17:27:37 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.14 movitz/losp/muerte/basic-macros.lisp:1.15 --- movitz/losp/muerte/basic-macros.lisp:1.14 Sat Apr 17 11:33:57 2004 +++ movitz/losp/muerte/basic-macros.lisp Sun Apr 18 17:27:37 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.14 2004/04/17 15:33:57 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.15 2004/04/18 21:27:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -384,11 +384,11 @@ (define-compiler-macro eq (&whole form &environment env x y) (cond ((movitz:movitz-constantp y env) - (let ((y (movitz::eval-form y env))) + (let ((y (movitz:movitz-eval y env))) (cond ((movitz:movitz-constantp x env) (warn "constant eq!: ~S" form) - (eq y (movitz::eval-form x env))) + (eq y (movitz:movitz-eval x env))) ((eq y nil) `(muerte::inlined-not ,x)) ((eql y 0) @@ -407,15 +407,13 @@ (t `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil) (:compile-two-forms (:eax :ebx) ,x ,y) (:cmpl :eax :ebx)))))) - ((and (movitz:movitz-constantp x env) - (typep (movitz::eval-form x env) - '(or symbol (unsigned-byte 30)))) - `(eq ,y ,x)) + ((movitz:movitz-constantp x env) + `(eq ,y ',(movitz:movitz-eval x env))) (t `(with-inline-assembly (:returns :boolean-zf=1 :side-effects nil) (:compile-two-forms (:eax :ebx) ,x ,y) (:cmpl :eax :ebx))))) -(define-compiler-macro eql (&whole form x y) +(define-compiler-macro eql (x y) `(eq ,x ,y)) (define-compiler-macro values (&rest sub-forms) From ffjeld at common-lisp.net Sun Apr 18 23:10:31 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 18 Apr 2004 19:10:31 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler-types.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7552 Modified Files: compiler-types.lisp Log Message: Changed how to deal with unknown types, slightly. Date: Sun Apr 18 19:10:31 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.10 movitz/compiler-types.lisp:1.11 --- movitz/compiler-types.lisp:1.10 Tue Apr 6 09:35:41 2004 +++ movitz/compiler-types.lisp Sun Apr 18 19:10:30 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.10 2004/04/06 13:35:41 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.11 2004/04/18 23:10:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -363,7 +363,7 @@ (numscope-intersection integer-range0 integer-range1)) (intersection members0 members1) (mapcar (lambda (sub0) - `(and ,sub0 (:encoded ,code1 ,integer-range1 ,members1 ,include1 nil))) + `(and ,sub0 ,(encoded-type-decode code1 integer-range1 members1 include1 nil))) include0) nil)) ((and (null include0) include1) @@ -373,7 +373,7 @@ (numscope-intersection integer-range0 integer-range1)) (intersection members0 members1) (mapcar (lambda (sub1) - `(and ,sub1 (:encoded ,code0 ,integer-range0 ,members0 ,include0 nil))) + `(and ,sub1 ,(encoded-type-decode code0 integer-range0 members0 include0 nil))) include1) nil)) (t (warn "and with two includes..") @@ -436,14 +436,12 @@ (t (let ((deriver (and (boundp 'muerte::*compiler-derived-typespecs*) (gethash type-specifier (symbol-value 'muerte::*compiler-derived-typespecs*))))) - (assert deriver (type-specifier) - "Unknown type ~S." type-specifier) - (type-specifier-encode (funcall deriver)))))) + (if deriver + (type-specifier-encode (funcall deriver)) + (type-values () :include (list type-specifier))))))) ((listp type-specifier) (check-type (car type-specifier) symbol) (case (car type-specifier) - (:encoded - (multiple-value-list (cdr type-specifier))) (satisfies (type-values () :include (list type-specifier))) (member From ffjeld at common-lisp.net Sun Apr 18 23:12:38 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 18 Apr 2004 19:12:38 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv16361 Modified Files: compiler.lisp Log Message: Fixed one compiler bug that would show itself compiling e.g. (setf x (setf y ...)). Also removed some improper use of ecx as temporary register. Date: Sun Apr 18 19:12:37 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.53 movitz/compiler.lisp:1.54 --- movitz/compiler.lisp:1.53 Sat Apr 17 11:33:45 2004 +++ movitz/compiler.lisp Sun Apr 18 19:12:37 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.53 2004/04/17 15:33:45 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.54 2004/04/18 23:12:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3064,7 +3064,7 @@ (or tmp-register (unless (member preferred protect-registers) preferred) - (first (set-difference '(:eax :ebx :ecx :edx) + (first (set-difference '(:eax :ebx :edx) protect-registers)) (error "Unable to chose a temporary register."))) (install-for-single-value (lexb lexb-location result-mode indirect-p) @@ -3238,8 +3238,8 @@ dest-location binding destination) - (append (install-for-single-value binding binding-location :ecx nil) - (make-store-lexical result-mode :ecx nil frame-map)))))) + (append (install-for-single-value binding binding-location :eax nil) + (make-store-lexical result-mode :eax nil frame-map)))))) (t (make-result-and-returns-glue result-mode :eax (install-for-single-value binding binding-location :eax nil))) @@ -4413,9 +4413,10 @@ ((:lexical-binding) (case (result-mode-type returns-provided) (:lexical-binding - (assert (eq desired-result returns-provided) () - "Desired-result ~S produced a value in ~S for code ~W." desired-result returns-provided code) - (values code returns-provided)) + (if (eq desired-result returns-provided) + (values code returns-provided) + (values (append code `((:load-lexical ,returns-provided ,desired-result))) + returns-provided))) ((:eax :multiple-values) (values (append code `((:store-lexical ,desired-result :eax From ffjeld at common-lisp.net Sun Apr 18 23:15:53 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 18 Apr 2004 19:15:53 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16219 Modified Files: basic-macros.lisp Log Message: minor edit. Date: Sun Apr 18 19:15:53 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.15 movitz/losp/muerte/basic-macros.lisp:1.16 --- movitz/losp/muerte/basic-macros.lisp:1.15 Sun Apr 18 17:27:37 2004 +++ movitz/losp/muerte/basic-macros.lisp Sun Apr 18 19:15:53 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.15 2004/04/18 21:27:37 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.16 2004/04/18 23:15:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -534,7 +534,7 @@ ((movitz:movitz-constantp place env) (assert (typep (movitz::eval-form place env) type)) nil) - (t (if (member type '(standard-gf-instance function pointer + (t (if (member type '(standard-gf-instance function pointer atom integer fixnum cons symbol character null list string vector simple-vector vector-u8 vector-u16)) `(unless (typep ,place ',type) From ffjeld at common-lisp.net Sun Apr 18 23:16:44 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 18 Apr 2004 19:16:44 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/characters.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv8777 Modified Files: characters.lisp Log Message: Don't use exception 60. Date: Sun Apr 18 19:16:44 2004 Author: ffjeld Index: movitz/losp/muerte/characters.lisp diff -u movitz/losp/muerte/characters.lisp:1.2 movitz/losp/muerte/characters.lisp:1.3 --- movitz/losp/muerte/characters.lisp:1.2 Mon Jan 19 06:23:46 2004 +++ movitz/losp/muerte/characters.lisp Sun Apr 18 19:16:44 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Feb 5 19:05:01 2001 ;;;; -;;;; $Id: characters.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $ +;;;; $Id: characters.lisp,v 1.3 2004/04/18 23:16:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -26,7 +26,7 @@ (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) character) (:cmpb #.(movitz::tag :character) :al) - (:jne '(:sub-program (not-a-character) (:int 60))) + (:jne '(:sub-program (not-a-character) (:int 66))) (:shrl #.(cl:- 8 movitz::+movitz-fixnum-shift+) :eax))) (defun code-char (code) From ffjeld at common-lisp.net Sun Apr 18 23:16:49 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 18 Apr 2004 19:16:49 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13920/losp/muerte Modified Files: defstruct.lisp Log Message: Don't use exception 60. Date: Sun Apr 18 19:16:49 2004 Author: ffjeld Index: movitz/losp/muerte/defstruct.lisp diff -u movitz/losp/muerte/defstruct.lisp:1.5 movitz/losp/muerte/defstruct.lisp:1.6 --- movitz/losp/muerte/defstruct.lisp:1.5 Mon Mar 29 09:53:13 2004 +++ movitz/losp/muerte/defstruct.lisp Sun Apr 18 19:16:49 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jan 22 13:10:59 2001 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defstruct.lisp,v 1.5 2004/03/29 14:53:13 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.6 2004/04/18 23:16:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -57,9 +57,9 @@ (:compile-form (:result-mode :eax) object) (:leal (:eax ,(- (movitz:tag :other))) :ecx) (:testb 7 :cl) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) (:cmpb ,(movitz:tag :defstruct) (-2 :eax)) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) ;; type test passed, read slot ,@(if (= 4 movitz::+movitz-fixnum-factor+) `((:compile-form (:result-mode :ebx) slot-number) @@ -78,9 +78,9 @@ (:compile-two-forms (:eax :ebx) object slot-number) (:leal (:eax ,(- (movitz:tag :other))) :ecx) (:testb 7 :cl) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) (:cmpb ,(movitz:tag :defstruct) (-2 :eax)) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) (:movzxw (:eax ,(bt:slot-offset 'movitz::movitz-struct 'movitz::length)) :ecx) (:leal ((:ecx ,movitz::+movitz-fixnum-factor+)) :ecx) (:testb ,movitz::+movitz-fixnum-zmask+ :bl) @@ -99,12 +99,12 @@ (:compile-form (:result-mode :eax) object) (:leal (:eax #.(cl:- (movitz:tag :other))) :ecx) (:testb 7 :cl) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) (:cmpb #.(movitz:tag :defstruct) (-2 :eax)) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) (:load-constant struct-name :ebx) (:cmpl :ebx (:eax #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name))) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) ;; type test passed, read slot (:load-constant slot-number :ecx) (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) @@ -118,12 +118,12 @@ ;; type test (:leal (:ebx #.(cl:- (movitz:tag :other))) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program (type-error) (:int 60))) + (:jnz '(:sub-program (type-error) (:int 66))) (:cmpb #.(movitz:tag :defstruct) (-2 :ebx)) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) (:load-constant struct-name :ecx) (:cmpl :ecx (:ebx #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name))) - (:jne '(:sub-program (type-error) (:int 60))) + (:jne '(:sub-program (type-error) (:int 66))) ;; type test passed, write slot (:load-constant slot-number :ecx) (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) From ffjeld at common-lisp.net Sun Apr 18 23:17:04 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 18 Apr 2004 19:17:04 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/common-lisp.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30454 Modified Files: common-lisp.lisp Log Message: Minor re-ordering. Date: Sun Apr 18 19:17:04 2004 Author: ffjeld Index: movitz/losp/muerte/common-lisp.lisp diff -u movitz/losp/muerte/common-lisp.lisp:1.4 movitz/losp/muerte/common-lisp.lisp:1.5 --- movitz/losp/muerte/common-lisp.lisp:1.4 Tue Apr 6 20:13:02 2004 +++ movitz/losp/muerte/common-lisp.lisp Sun Apr 18 19:17:04 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:41:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: common-lisp.lisp,v 1.4 2004/04/07 00:13:02 ffjeld Exp $ +;;;; $Id: common-lisp.lisp,v 1.5 2004/04/18 23:17:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -43,11 +43,11 @@ (require :muerte/eval) (require :muerte/los-closette) (require :muerte/environment) -(require :muerte/interrupt) (require :muerte/streams) (require :muerte/restarts) (require :muerte/conditions) (require :muerte/read) +(require :muerte/interrupt) (require :muerte/scavenge) (require :muerte/simple-streams) From ffjeld at common-lisp.net Sun Apr 18 23:17:36 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 18 Apr 2004 19:17:36 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/conditions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1525 Modified Files: conditions.lisp Log Message: Added a reporter. Date: Sun Apr 18 19:17:36 2004 Author: ffjeld Index: movitz/losp/muerte/conditions.lisp diff -u movitz/losp/muerte/conditions.lisp:1.5 movitz/losp/muerte/conditions.lisp:1.6 --- movitz/losp/muerte/conditions.lisp:1.5 Thu Apr 15 11:11:44 2004 +++ movitz/losp/muerte/conditions.lisp Sun Apr 18 19:17:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 20 15:47:04 2002 ;;;; -;;;; $Id: conditions.lisp,v 1.5 2004/04/15 15:11:44 ffjeld Exp $ +;;;; $Id: conditions.lisp,v 1.6 2004/04/18 23:17:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -94,7 +94,11 @@ :reader type-error-expected-type) (datum :initarg :datum - :reader type-error-datum))) + :reader type-error-datum)) + (:report (lambda (c s) + (format s "The object ~S is not of type ~S." + (type-error-datum c) + (type-error-expected-type c))))) (define-condition control-error (error) ()) From ffjeld at common-lisp.net Sun Apr 18 23:17:59 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 18 Apr 2004 19:17:59 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21745 Modified Files: interrupt.lisp Log Message: *** empty log message *** Date: Sun Apr 18 19:17:59 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.6 movitz/losp/muerte/interrupt.lisp:1.7 --- movitz/losp/muerte/interrupt.lisp:1.6 Thu Apr 15 11:23:36 2004 +++ movitz/losp/muerte/interrupt.lisp Sun Apr 18 19:17:58 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.6 2004/04/15 15:23:36 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.7 2004/04/18 23:17:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -166,6 +166,12 @@ $eip (interrupt-frame-ref interrupt-frame :error-code :unsigned-byte32) $eax $ebx $ecx)) + ((61) + ;; EAX failed type in EDX. May be restarted by returning with a new value in EAX. + (with-simple-restart (continue "Retry with a different value.") + (error 'type-error :datum (@ $eax) :expected-type (@ $edx))) + (format *query-io* "Enter a new value: ") + (setf (@ $eax) (read *query-io*))) (68 (warn "EIP: ~@Z EAX: ~@Z EBX: ~@Z ECX: ~@Z EDX: ~@Z" $eip $eax $ebx $ecx $edx) (dotimes (i 100000) From ffjeld at common-lisp.net Sun Apr 18 23:18:32 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 18 Apr 2004 19:18:32 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23169 Modified Files: functions.lisp Log Message: Use the type function rather than compiled-function. Date: Sun Apr 18 19:18:32 2004 Author: ffjeld Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.9 movitz/losp/muerte/functions.lisp:1.10 --- movitz/losp/muerte/functions.lisp:1.9 Thu Apr 15 14:53:15 2004 +++ movitz/losp/muerte/functions.lisp Sun Apr 18 19:18:31 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.9 2004/04/15 18:53:15 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.10 2004/04/18 23:18:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -76,18 +76,18 @@ ;;; funobj object (defun funobj-type (funobj) - (check-type funobj compiled-function) + (check-type funobj function) (with-inline-assembly (:returns :untagged-fixnum-ecx) (:xorl :ecx :ecx) (:compile-form (:result-mode :eax) funobj) (:movb (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:funobj-type)) :cl))) (defun funobj-code-vector (funobj) - (check-type funobj compiled-function) + (check-type funobj function) (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :code-vector)) (defun (setf funobj-code-vector) (code-vector funobj) - (check-type funobj compiled-function) + (check-type funobj function) (check-type code-vector vector-u8) (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :code-vector) code-vector)) @@ -97,7 +97,7 @@ a pointer into the regular code-vector, or it points (with offset 2) to another vector entirely. The former is represented as a lisp integer that is the index into the code-vector, the latter is represented as that vector." - (check-type funobj compiled-function) + (check-type funobj function) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) funobj) (:movl (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) :ebx) ; EBX = code-vector @@ -119,7 +119,7 @@ done)) ; this cell stores word+2 (defun (setf funobj-code-vector%1op) (code-vector funobj) - (check-type funobj compiled-function) + (check-type funobj function) (etypecase code-vector (vector-u8 (with-inline-assembly (:returns :nothing) @@ -142,7 +142,7 @@ a pointer into the regular code-vector, or it points (with offset 2) to another vector entirely. The former is represented as a lisp integer that is the index into the code-vector, the latter is represented as that vector." - (check-type funobj compiled-function) + (check-type funobj function) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) funobj) (:movl (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) :ebx) ; EBX = code-vector @@ -164,7 +164,7 @@ done)) (defun (setf funobj-code-vector%2op) (code-vector funobj) - (check-type funobj compiled-function) + (check-type funobj function) (etypecase code-vector (vector-u8 (with-inline-assembly (:returns :nothing) @@ -187,7 +187,7 @@ a pointer into the regular code-vector, or it points (with offset 2) to another vector entirely. The former is represented as a lisp integer that is the index into the code-vector, the latter is represented as that vector." - (check-type funobj compiled-function) + (check-type funobj function) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) funobj) (:movl (:eax #.(bt::slot-offset 'movitz:movitz-funobj 'movitz:code-vector)) :ebx) ; EBX = code-vector @@ -209,7 +209,7 @@ done)) (defun (setf funobj-code-vector%3op) (code-vector funobj) - (check-type funobj compiled-function) + (check-type funobj function) (etypecase code-vector (vector-u8 (with-inline-assembly (:returns :nothing) @@ -228,47 +228,47 @@ code-vector) (defun funobj-name (funobj) - (check-type funobj compiled-function) + (check-type funobj function) (movitz-accessor funobj movitz-funobj name)) (defun (setf funobj-name) (name funobj) - (check-type funobj compiled-function) + (check-type funobj function) ;; (check-type name (or symbol list) (setf-movitz-accessor (funobj movitz-funobj name) name)) (defun funobj-lambda-list (funobj) - (check-type funobj compiled-function) + (check-type funobj function) (movitz-accessor funobj movitz-funobj lambda-list)) (defun (setf funobj-lambda-list) (lambda-list funobj) - (check-type funobj compiled-function) + (check-type funobj function) (check-type lambda-list list) (setf-movitz-accessor (funobj movitz-funobj lambda-list) lambda-list)) (defun funobj-num-constants (funobj) - (check-type funobj compiled-function) + (check-type funobj function) (movitz-accessor-u16 funobj movitz-funobj num-constants)) (defun (setf funobj-num-constants) (num-constants funobj) - (check-type funobj compiled-function) + (check-type funobj function) (check-type num-constants (unsigned-byte 16)) (set-movitz-accessor-u16 funobj movitz-funobj num-constants num-constants)) (defun funobj-num-jumpers (funobj) - (check-type funobj compiled-function) + (check-type funobj function) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) funobj) (:movzxw (:eax #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::num-jumpers)) :eax))) (defun (setf funobj-num-jumpers) (num-jumpers funobj) - (check-type funobj compiled-function) + (check-type funobj function) (check-type num-jumpers (unsigned-byte 14)) (with-inline-assembly (:returns :eax) (:compile-two-forms (:eax :ebx) num-jumpers funobj) (:movw :ax (:ebx #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::num-jumpers))))) (defun funobj-constant-ref (funobj index) - (check-type funobj compiled-function) + (check-type funobj function) (assert (below index (funobj-num-constants funobj)) (index) "Index ~D out of range, ~S has ~D constants." index funobj (funobj-num-constants funobj)) (if (>= index (funobj-num-jumpers funobj)) @@ -287,7 +287,7 @@ (:leal ((:ebx #.movitz:+movitz-fixnum-factor+)) :eax)))) (defun (setf funobj-constant-ref) (value funobj index) - (check-type funobj compiled-function) + (check-type funobj function) (assert (below index (funobj-num-constants funobj)) (index) "Index ~D out of range, ~S has ~D constants." index funobj (funobj-num-constants funobj)) (if (>= index (funobj-num-jumpers funobj)) @@ -311,7 +311,7 @@ value))) (defun funobj-debug-info (funobj) - (check-type funobj compiled-function) + (check-type funobj function) (movitz-accessor-u16 funobj movitz-funobj debug-info)) (defun funobj-frame-num-unboxed (funobj) From ffjeld at common-lisp.net Mon Apr 19 00:29:35 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 18 Apr 2004 20:29:35 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler-types.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv21868 Modified Files: compiler-types.lisp Log Message: Minor improvements. Date: Sun Apr 18 20:29:35 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.11 movitz/compiler-types.lisp:1.12 --- movitz/compiler-types.lisp:1.11 Sun Apr 18 19:10:30 2004 +++ movitz/compiler-types.lisp Sun Apr 18 20:29:35 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.11 2004/04/18 23:10:30 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.12 2004/04/19 00:29:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -266,14 +266,14 @@ sub-specs))) (cond ((null sub-specs) - (and complement t)) + (if complement t nil)) ((not (cdr sub-specs)) (if (not complement) (car sub-specs) - (cons 'not (car sub-specs)))) + (list 'not (car sub-specs)))) (t (if (not complement) (cons 'or sub-specs) - (cons 'not (cons 'or sub-specs)))))))) + (list 'not (cons 'or sub-specs)))))))) (defun type-values (codes &key integer-range members include complement) ;; Members: A list of objects explicitly included in type. @@ -376,9 +376,20 @@ `(and ,sub1 ,(encoded-type-decode code0 integer-range0 members0 include0 nil))) include1) nil)) - (t (warn "and with two includes..") - (type-values t)))) - (t (error "Not implemented.")))) + (t ;; (warn "and with two includes: ~S ~S" include0 include1) + (type-values () :include `(and ,(encoded-type-decode code0 integer-range0 members0 + include0 complement0) + ,(encoded-type-decode code1 integer-range1 members1 + include1 complement1)))))) + ((and complement0 complement1) + (multiple-value-bind (code integer-range members include complement) + (encoded-types-or code0 integer-range0 members0 include0 (not complement0) + code1 integer-range1 members1 include1 (not complement1)) + (values code integer-range members include (not complement)))) + (t (type-values () :include `(and ,(encoded-type-decode code0 integer-range0 members0 + include0 complement0) + ,(encoded-type-decode code1 integer-range1 members1 + include1 complement1)))))) (defun encoded-types-or (code0 integer-range0 members0 include0 complement0 code1 integer-range1 members1 include1 complement1) From ffjeld at common-lisp.net Mon Apr 19 15:02:54 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 11:02:54 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7168 Modified Files: compiler.lisp Log Message: Minor edits. Date: Mon Apr 19 11:02:54 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.54 movitz/compiler.lisp:1.55 --- movitz/compiler.lisp:1.54 Sun Apr 18 19:12:37 2004 +++ movitz/compiler.lisp Mon Apr 19 11:02:53 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.54 2004/04/18 23:12:37 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.55 2004/04/19 15:02:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -63,6 +63,12 @@ (defvar *compiling-function-name*) (defvar muerte.cl:*compile-file-pathname* nil) +(defvar *extended-code-expanders* + (make-hash-table :test #'eq)) + +(defvar *extended-code-find-write-binding-and-type* + (make-hash-table :test #'eq)) + (defconstant +enter-stack-frame-code+ '((:pushl :ebp) (:movl :esp :ebp) @@ -5542,9 +5548,6 @@ (check-type result list "a list of read bindings") result))))) -(defvar *extended-code-find-write-binding-and-type* - (make-hash-table :test #'eq)) - (defmacro define-find-write-binding-and-type (name lambda-list &body body) (let ((defun-name (intern (with-standard-io-syntax @@ -5559,9 +5562,6 @@ (finder (gethash operator *extended-code-find-write-binding-and-type*))) (when finder (funcall finder extended-instruction))))) - -(defvar *extended-code-expanders* - (make-hash-table :test #'eq)) (defmacro define-extended-code-expander (name lambda-list &body body) (let ((defun-name (intern From ffjeld at common-lisp.net Mon Apr 19 15:04:32 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 11:04:32 -0400 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22672 Modified Files: packages.lisp Log Message: More symbols. Date: Mon Apr 19 11:04:32 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.19 movitz/packages.lisp:1.20 --- movitz/packages.lisp:1.19 Fri Apr 16 15:21:13 2004 +++ movitz/packages.lisp Mon Apr 19 11:04:32 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.19 2004/04/16 19:21:13 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.20 2004/04/19 15:04:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1186,10 +1186,12 @@ map-active-restarts with-basic-restart - vector-u8 - vector-u16 - vector-u32 - pointer + #:vector-u8 + #:vector-u16 + #:vector-u32 + #:pointer + #:basic-restart + #:run-time-context make-funobj funobj-type From ffjeld at common-lisp.net Mon Apr 19 15:05:02 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 11:05:02 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/run-time-context.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv928 Modified Files: run-time-context.lisp Log Message: Minor edit. Date: Mon Apr 19 11:05:01 2004 Author: ffjeld Index: movitz/losp/muerte/run-time-context.lisp diff -u movitz/losp/muerte/run-time-context.lisp:1.5 movitz/losp/muerte/run-time-context.lisp:1.6 --- movitz/losp/muerte/run-time-context.lisp:1.5 Tue Apr 6 20:18:57 2004 +++ movitz/losp/muerte/run-time-context.lisp Mon Apr 19 11:05:01 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Nov 12 18:33:02 2003 ;;;; -;;;; $Id: run-time-context.lisp,v 1.5 2004/04/07 00:18:57 ffjeld Exp $ +;;;; $Id: run-time-context.lisp,v 1.6 2004/04/19 15:05:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -65,7 +65,7 @@ (if (not (and (movitz:movitz-constantp slot-name env) (equal context '(current-run-time-context)))) form - (let ((slot-name (movitz::eval-form slot-name env))) + (let ((slot-name (movitz:movitz-eval slot-name env))) (ecase (bt:binary-slot-type 'movitz::movitz-constant-block (intern (symbol-name slot-name) :movitz)) (movitz:word `(with-inline-assembly (:returns :eax) From ffjeld at common-lisp.net Mon Apr 19 15:06:21 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 11:06:21 -0400 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4443 Modified Files: image.lisp Log Message: Changed the way (find-class ') is optimized for certain well-known classes. The idea is to avoid the normal hash-table lookup for some often-named classes. Date: Mon Apr 19 11:06:21 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.25 movitz/image.lisp:1.26 --- movitz/image.lisp:1.25 Sat Apr 17 11:33:51 2004 +++ movitz/image.lisp Mon Apr 19 11:06:21 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.25 2004/04/17 15:33:51 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.26 2004/04/19 15:06:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -276,22 +276,35 @@ :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) + (complicated-class-of + :binary-type word + :binary-tag :global-function + :map-binary-read-delayed 'movitz-word + :map-binary-write 'movitz-intern) (num-values :binary-type lu32 :initform 0) (values :binary-type #.(* 4 +movitz-multiple-values-limit+)) - (default-interrupt-trampoline :map-binary-write 'movitz-intern-code-vector :binary-tag :primitive-function :map-binary-read-delayed 'movitz-word-code-vector :binary-type code-vector-word) - (complicated-class-of + (classes ; A vector of class meta-objects. + :initform nil ; The first element is the map of corresponding names :binary-type word - :binary-tag :global-function - :map-binary-read-delayed 'movitz-word - :map-binary-write 'movitz-intern) + :map-binary-write (lambda (x type) + (declare (ignore x type)) + (let ((map (image-classes-map *image*))) + (movitz-read-and-intern + (apply #'vector + map + (mapcar (lambda (x) + (funcall 'muerte::movitz-find-class x)) + map)) + 'word))) + :map-binary-read-delayed 'movitz-word) ;; Some well-known classes (the-class-t :binary-type word @@ -301,38 +314,38 @@ (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) 'word)) :map-binary-read-delayed 'movitz-word) - (the-class-fixnum - :binary-type word - :initform 'fixnum - :map-binary-write (lambda (x type) - (declare (ignore type)) - (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) - 'word)) - :map-binary-read-delayed 'movitz-word) - (the-class-cons - :binary-type word - :initform 'cons - :map-binary-write (lambda (x type) - (declare (ignore type)) - (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) - 'word)) - :map-binary-read-delayed 'movitz-word) - (the-class-null - :binary-type word - :initform 'null - :map-binary-write (lambda (x type) - (declare (ignore type)) - (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) - 'word)) - :map-binary-read-delayed 'movitz-word) - (the-class-symbol - :binary-type word - :initform 'symbol - :map-binary-write (lambda (x type) - (declare (ignore type)) - (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) - 'word)) - :map-binary-read-delayed 'movitz-word) +;;; (the-class-fixnum +;;; :binary-type word +;;; :initform 'fixnum +;;; :map-binary-write (lambda (x type) +;;; (declare (ignore type)) +;;; (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) +;;; 'word)) +;;; :map-binary-read-delayed 'movitz-word) +;;; (the-class-cons +;;; :binary-type word +;;; :initform 'cons +;;; :map-binary-write (lambda (x type) +;;; (declare (ignore type)) +;;; (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) +;;; 'word)) +;;; :map-binary-read-delayed 'movitz-word) +;;; (the-class-null +;;; :binary-type word +;;; :initform 'null +;;; :map-binary-write (lambda (x type) +;;; (declare (ignore type)) +;;; (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) +;;; 'word)) +;;; :map-binary-read-delayed 'movitz-word) +;;; (the-class-symbol +;;; :binary-type word +;;; :initform 'symbol +;;; :map-binary-write (lambda (x type) +;;; (declare (ignore type)) +;;; (movitz-read-and-intern (funcall 'muerte::movitz-find-class x) +;;; 'word)) +;;; :map-binary-read-delayed 'movitz-word) (interrupt-handlers :binary-type word :map-binary-write 'movitz-intern @@ -526,6 +539,22 @@ :initform (make-hash-table :test #'equal) :initarg :function-code-sizes :reader function-code-sizes))) + +(defmethod image-classes-map ((image symbolic-image)) + '(muerte.cl:null muerte.cl:cons muerte.cl:fixnum muerte.cl:symbol + muerte.cl:character muerte.cl:function muerte.cl:condition + muerte.cl:vector muerte.cl:string muerte.cl:array + muerte.cl:class muerte.cl:standard-class + muerte.cl:standard-generic-function + muerte:run-time-context + muerte.mop:standard-effective-slot-definition + muerte.mop:funcallable-standard-class + muerte:basic-restart)) + +(defun class-object-offset (name) + (+ (bt:slot-offset 'movitz-vector 'data) + (* 4 (1+ (or (position name (image-classes-map *image*)) + (error "No class named ~S in class-map." name)))))) (defun unbound-value () (declare (special *image*)) From ffjeld at common-lisp.net Mon Apr 19 15:06:26 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 11:06:26 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11596 Modified Files: basic-macros.lisp Log Message: Changed the way (find-class ') is optimized for certain well-known classes. The idea is to avoid the normal hash-table lookup for some often-named classes. Date: Mon Apr 19 11:06:26 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.16 movitz/losp/muerte/basic-macros.lisp:1.17 --- movitz/losp/muerte/basic-macros.lisp:1.16 Sun Apr 18 19:15:53 2004 +++ movitz/losp/muerte/basic-macros.lisp Mon Apr 19 11:06:26 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.16 2004/04/18 23:15:53 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.17 2004/04/19 15:06:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -860,13 +860,26 @@ (declare (ignore errorp)) (if (not (movitz:movitz-constantp symbol env)) form - (case (movitz::translate-program (movitz::eval-form symbol env) :muerte.cl :cl) - ((t) `(load-global-constant the-class-t)) - (fixnum '(load-global-constant the-class-fixnum)) - (null `(load-global-constant the-class-null)) - (symbol '(load-global-constant the-class-symbol)) - (cons '(load-global-constant the-class-cons)) - (t form)))) + (let* ((type (movitz:movitz-eval symbol env)) + (cl-type (movitz::translate-program type :muerte.cl :cl))) + (cond + ((eq t cl-type) + `(load-global-constant the-class-t)) + ((member type (movitz::image-classes-map movitz:*image*)) + `(with-inline-assembly (:returns :register) + (:globally (:movl (:edi (:edi-offset classes)) (:result-register))) + (:movl ((:result-register) ,(movitz::class-object-offset type)) + (:result-register)))) + (t (warn "unknown find-class: ~A" cl-type) + form)) + #+ignore + (case cl-type + ((t) `(load-global-constant the-class-t)) + (fixnum '(load-global-constant the-class-fixnum)) + (null `(load-global-constant the-class-null)) + (symbol '(load-global-constant the-class-symbol)) + (cons '(load-global-constant the-class-cons)) + (t form))))) (define-compiler-macro class-of (object) `(with-inline-assembly (:returns :eax) @@ -886,7 +899,7 @@ (:leal ((:result-register) ,(- (movitz::tag :other))) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program () (:int 68))) + (:jnz '(:sub-program () (:int 66))) (:movl ((:result-register) ,(bt:slot-offset 'movitz::movitz-std-instance slot)) (:result-register)))))) @@ -898,7 +911,7 @@ (:leal (:ebx ,(- (movitz::tag :other))) :ecx) (:testb 7 :cl) - (:jnz '(:sub-program () (:int 68))) + (:jnz '(:sub-program () (:int 66))) (:movl :eax (:ebx ,(bt:slot-offset 'movitz::movitz-std-instance slot))))))) @@ -982,11 +995,6 @@ (:locally (:movl (:edi (:edi-offset ,name)) :ecx))) `(with-inline-assembly (:returns :untagged-fixnum-ecx) (:globally (:movl (:edi (:edi-offset ,name)) :ecx))))) - -;;;(define-compiler-macro (setf %runtime-context-slot) (value slot-name) -;;; `(with-inline-assembly (:returns :eax) -;;; (:compile-form (:result-mode :eax) ,value) -;;; (:movl :eax (:edi ,(movitz::global-constant-offset (movitz::eval-form slot-name)))))) (define-compiler-macro halt-cpu () (let ((infinite-loop-label (make-symbol "infinite-loop"))) From ffjeld at common-lisp.net Mon Apr 19 15:06:32 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 11:06:32 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19544 Modified Files: los-closette.lisp Log Message: Changed the way (find-class ') is optimized for certain well-known classes. The idea is to avoid the normal hash-table lookup for some often-named classes. Date: Mon Apr 19 11:06:32 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.7 movitz/losp/muerte/los-closette.lisp:1.8 --- movitz/losp/muerte/los-closette.lisp:1.7 Wed Apr 14 18:01:30 2004 +++ movitz/losp/muerte/los-closette.lisp Mon Apr 19 11:06:32 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.7 2004/04/14 22:01:30 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.8 2004/04/19 15:06:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -208,12 +208,17 @@ (defun (setf find-class) (class class-name) (check-type class (or null class)) + #+ignore (case class-name ((t) (setf (%run-time-context-slot 'the-class-t) class)) (null (setf (%run-time-context-slot 'the-class-null) class)) (symbol (setf (%run-time-context-slot 'the-class-symbol) class)) (fixnum (setf (%run-time-context-slot 'the-class-fixnum) class)) (cons (setf (%run-time-context-slot 'the-class-cons) class))) + (let ((map (load-global-constant classes))) + (when (member class-name (svref map 0)) + (setf (svref map (1+ (position class-name (svref map 0)))) + class))) (if class (setf (gethash class-name *class-table*) class) (remhash class-name *class-table*)) @@ -896,9 +901,6 @@ `(defun ,name (instance) (with-inline-assembly (:returns :multiple-values) (:compile-form (:result-mode :eax) instance) -;;; (:leal (:eax -2) :ecx) -;;; (:testb 7 :cl) -;;; (:jnz '(:sub-program () (:int 68))) (:movl (:eax ,(bt:slot-offset 'movitz::movitz-std-instance 'movitz::slots)) :eax) (:movl (:eax ,(+ (bt:slot-offset 'movitz::movitz-vector 'movitz::data) @@ -1776,11 +1778,6 @@ (warn "CLOS was already bootstrapped: ~S" (get 'clos-bootstrap 'have-bootstrapped))) (setf (get 'clos-bootstrap 'have-bootstrapped) :in-progress) - #+ignore - (setf (runtime-context-slot 'the-class-t) (gethash 't *class-table*) - (runtime-context-slot 'the-class-null) (gethash 'null *class-table*) - (runtime-context-slot 'the-class-symbol) (gethash 'symbol *class-table*) - (runtime-context-slot 'the-class-cons) (gethash 'cons *class-table*)) (let ((real-camuc #'compute-applicable-methods-using-classes) (real-class-slots #'class-slots) (real-class-precedence-list #'class-precedence-list) From ffjeld at common-lisp.net Mon Apr 19 15:06:38 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 11:06:38 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23371 Modified Files: primitive-functions.lisp Log Message: Changed the way (find-class ') is optimized for certain well-known classes. The idea is to avoid the normal hash-table lookup for some often-named classes. Date: Mon Apr 19 11:06:38 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.13 movitz/losp/muerte/primitive-functions.lisp:1.14 --- movitz/losp/muerte/primitive-functions.lisp:1.13 Fri Apr 16 19:35:29 2004 +++ movitz/losp/muerte/primitive-functions.lisp Mon Apr 19 11:06:38 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.13 2004/04/16 23:35:29 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.14 2004/04/19 15:06:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -519,21 +519,32 @@ (define-primitive-function fast-class-of-even-fixnum () "Return the class of a fixnum object." (with-inline-assembly (:returns :multiple-values) - (:globally (:movl (:edi (:edi-offset the-class-fixnum)) :eax)) + (:globally (:movl (:edi (:edi-offset classes)) :eax)) + (:movl (:eax #.(movitz::class-object-offset 'fixnum)) :eax) (:ret))) (define-primitive-function fast-class-of-odd-fixnum () "Return the class of a fixnum object." (with-inline-assembly (:returns :multiple-values) - (:globally (:movl (:edi (:edi-offset the-class-fixnum)) :eax)) + (:globally (:movl (:edi (:edi-offset classes)) :eax)) + (:movl (:eax #.(movitz::class-object-offset 'fixnum)) :eax) (:ret))) (define-primitive-function fast-class-of-cons () "Return the class of a cons object." (with-inline-assembly (:returns :multiple-values) - (:globally (:movl (:edi (:edi-offset the-class-cons)) :eax)) + (:globally (:movl (:edi (:edi-offset classes)) :eax)) + (:movl (:eax #.(movitz::class-object-offset 'cons)) :eax) (:ret))) +(define-primitive-function fast-class-of-symbol () + "Return the class of a symbol object." + (with-inline-assembly (:returns :multiple-values) + (:globally (:movl (:edi (:edi-offset classes)) :eax)) + (:movl (:eax #.(movitz::class-object-offset 'symbol)) :eax) + (:ret))) + + (define-primitive-function fast-class-of-std-instance () "Return the class of a std-instance object." (with-inline-assembly (:returns :multiple-values) @@ -550,19 +561,23 @@ (define-primitive-function fast-class-of-character () "Return the class of a character object." (with-inline-assembly (:returns :multiple-values) - (:globally (:movl (:edi (:edi-offset complicated-class-of)) :esi)) - (:jmp (:esi #.(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%1op))))) + (:globally (:movl (:edi (:edi-offset classes)) :eax)) + (:movl (:eax #.(movitz::class-object-offset 'character)) :eax) + (:ret))) (define-primitive-function fast-class-of-null () "Return the class of a nil object." (with-inline-assembly (:returns :multiple-values) - (:globally (:movl (:edi (:edi-offset the-class-null)) :eax)) + (:cmpl :edi :eax) + (:jne '(:sub-program () (:int 64))) + (:globally (:movl (:edi (:edi-offset classes)) :eax)) + (:movl (:eax #.(movitz::class-object-offset 'null)) :eax) (:ret))) (define-primitive-function fast-class-of-other () "Return the class of an other object." (with-inline-assembly (:returns :multiple-values) - (:movw (:eax -2) :cx) + (:movl (:eax -2) :ecx) (:cmpb #.(movitz::tag :std-instance) :cl) (:jne 'not-std-instance) (:movl (:eax #.(bt:slot-offset 'movitz::movitz-std-instance 'movitz::class)) :eax) @@ -579,12 +594,6 @@ (:globally (:movl (:edi (:edi-offset complicated-class-of)) :esi)) (:jmp (:esi #.(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%1op))))) -(define-primitive-function fast-class-of-symbol () - "Return the class of a symbol object." - (with-inline-assembly (:returns :multiple-values) - (:globally (:movl (:edi (:edi-offset the-class-symbol)) :eax)) - (:ret))) - (defun complicated-class-of (object) (typecase object (std-instance @@ -595,7 +604,7 @@ (find-class 'string)) (vector (find-class 'vector)) - (compiled-function + (function (find-class 'function)) (structure-object (find-class (structure-object-name object))) From ffjeld at common-lisp.net Mon Apr 19 19:49:11 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 15:49:11 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv31584 Modified Files: primitive-functions.lisp Log Message: Fixed fast-class-of-null and fast-class-of-character so that they actually do what they're supposed to do. Date: Mon Apr 19 15:49:11 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.14 movitz/losp/muerte/primitive-functions.lisp:1.15 --- movitz/losp/muerte/primitive-functions.lisp:1.14 Mon Apr 19 11:06:38 2004 +++ movitz/losp/muerte/primitive-functions.lisp Mon Apr 19 15:49:11 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.14 2004/04/19 15:06:38 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.15 2004/04/19 19:49:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -561,8 +561,12 @@ (define-primitive-function fast-class-of-character () "Return the class of a character object." (with-inline-assembly (:returns :multiple-values) - (:globally (:movl (:edi (:edi-offset classes)) :eax)) - (:movl (:eax #.(movitz::class-object-offset 'character)) :eax) + (:globally (:movl (:edi (:edi-offset classes)) :ebx)) + (:cmpb #.(movitz:tag :character) :al) + (:jne '(:sub-program () + (:globally (:movl (:edi (:edi-offset complicated-class-of)) :esi)) + (:jmp (:esi #.(bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector%1op))))) + (:movl (:ebx #.(movitz::class-object-offset 'character)) :eax) (:ret))) (define-primitive-function fast-class-of-null () From ffjeld at common-lisp.net Mon Apr 19 19:51:01 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 15:51:01 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18778 Modified Files: typep.lisp Log Message: Added knowledge of the satisfies type in typep's compiler-macro. Date: Mon Apr 19 15:51:01 2004 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.10 movitz/losp/muerte/typep.lisp:1.11 --- movitz/losp/muerte/typep.lisp:1.10 Sat Apr 17 10:08:24 2004 +++ movitz/losp/muerte/typep.lisp Mon Apr 19 15:51:01 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.10 2004/04/17 14:08:24 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.11 2004/04/19 19:51:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -294,6 +294,11 @@ not-fixnum))))))) ((eql) `(eql ,object ',(cadr type))) + ((satisfies) + (destructuring-bind (predicate-name) + (cdr type) + (check-type predicate-name symbol "a satisfies predicate-name") + `(,predicate-name ,object))) ((cons) (destructuring-bind (&optional (car t) (cdr t)) (cdr type) From ffjeld at common-lisp.net Mon Apr 19 20:01:09 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 16:01:09 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11801 Modified Files: more-macros.lisp Log Message: Added macro with-slots. Date: Mon Apr 19 16:01:08 2004 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.5 movitz/losp/muerte/more-macros.lisp:1.6 --- movitz/losp/muerte/more-macros.lisp:1.5 Tue Apr 6 10:05:23 2004 +++ movitz/losp/muerte/more-macros.lisp Mon Apr 19 16:01:08 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.5 2004/04/06 14:05:23 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.6 2004/04/19 20:01:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -292,3 +292,13 @@ (defmacro ignore-errors (&body body) `(handler-case (progn , at body) (error (c) (values nil c)))) + +(defmacro with-slots (slot-entries instance-form &body declarations-and-forms) + (let ((object-var (gensym "with-slots-object-"))) + `(symbol-macrolet ,(mapcar (lambda (entry) + (let ((var (if (atom entry) entry (car entry))) + (slot (if (atom entry) entry (cadr entry)))) + `(,var (slot-value ,object-var ',slot)))) + slot-entries) + (let ((,object-var ,instance-form)) + , at declarations-and-forms)))) \ No newline at end of file From ffjeld at common-lisp.net Mon Apr 19 20:34:56 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 16:34:56 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18707 Modified Files: compiler.lisp Log Message: Fixed a nasty compiler bug that would overwrite one function-argument with another in certain instances. Date: Mon Apr 19 16:34:56 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.55 movitz/compiler.lisp:1.56 --- movitz/compiler.lisp:1.55 Mon Apr 19 11:02:53 2004 +++ movitz/compiler.lisp Mon Apr 19 16:34:55 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.55 2004/04/19 15:02:53 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.56 2004/04/19 20:34:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -3763,10 +3763,7 @@ (let ((required-vars (required-vars env)) (min-args (min-args env)) (max-args (max-args env))) - (let (#+ignore (max-used-arg (loop for (binding) in frame-map - when (typep binding 'positional-function-argument) - maximize (function-argument-argnum binding))) - (stack-setup-size stack-frame-size) + (let ((stack-setup-size stack-frame-size) (edx-needs-saving-p (and (edx-var env) (new-binding-location (edx-var env) frame-map :default nil)))) (multiple-value-bind (eax-ebx-code eax-ebx-code-post-stackframe) @@ -3830,8 +3827,8 @@ after-code `((:movl (:ebp (:ecx 4) ,(* -4 (1- (function-argument-argnum binding)))) - :eax) - (:movl :eax (:ebp ,(stack-frame-offset + :edx) + (:movl :edx (:ebp ,(stack-frame-offset (new-binding-location binding frame-map))))))))))) (values before-code after-code))) (t (values (append @@ -3877,10 +3874,11 @@ append `((:movl (:ebp (:ecx 4) ,(* -4 (1- (function-argument-argnum binding)))) - :eax) - (:movl :eax (:ebp ,(stack-frame-offset + :edx) + (:movl :edx (:ebp ,(stack-frame-offset (new-binding-location binding frame-map))))) - and do (setq need-normalized-ecx-p t)))))) + and do + (setq need-normalized-ecx-p t)))))) (assert (not (minusp stack-setup-size))) (let ((stack-frame-init-code (append (when (and do-check-stack-p use-stack-frame-p @@ -3889,9 +3887,9 @@ `((,*compiler-local-segment-prefix* :bound (:edi ,(global-constant-offset 'stack-bottom)) :esp))) (when use-stack-frame-p - `((:pushl :ebp) - (:movl :esp :ebp) - (:pushl :esi)))))) + `((:pushl :ebp) + (:movl :esp :ebp) + (:pushl :esi)))))) (values (append (cond @@ -4002,7 +4000,7 @@ (:movl :edi (:ebp ,(stack-frame-offset (1+ lended-cons-position)))) ; car (:leal (:ebp 1 ,(stack-frame-offset (1+ lended-cons-position))) :edx) (:movl :edx (:ebp ,(stack-frame-offset location)))))))))) - need-normalized-ecx-p)))))) + need-normalized-ecx-p)))))) (defparameter *restify-stats* (make-hash-table :test #'eql)) From ffjeld at common-lisp.net Mon Apr 19 22:38:12 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 18:38:12 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/common-lisp.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18312 Modified Files: common-lisp.lisp Log Message: Changed structure-class and defstruct so as to be better integrated with the MOP. This means that the slot-value accessor should now work on structure-objects. Date: Mon Apr 19 18:38:12 2004 Author: ffjeld Index: movitz/losp/muerte/common-lisp.lisp diff -u movitz/losp/muerte/common-lisp.lisp:1.5 movitz/losp/muerte/common-lisp.lisp:1.6 --- movitz/losp/muerte/common-lisp.lisp:1.5 Sun Apr 18 19:17:04 2004 +++ movitz/losp/muerte/common-lisp.lisp Mon Apr 19 18:38:11 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:41:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: common-lisp.lisp,v 1.5 2004/04/18 23:17:04 ffjeld Exp $ +;;;; $Id: common-lisp.lisp,v 1.6 2004/04/19 22:38:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -34,6 +34,7 @@ (require :muerte/inspect) (require :muerte/strings) (require :muerte/print) +(require :muerte/los-closette) (require :muerte/defstruct) (require :muerte/hash-tables) (require :muerte/packages) @@ -41,7 +42,6 @@ (require :muerte/error) (require :muerte/loop) (require :muerte/eval) -(require :muerte/los-closette) (require :muerte/environment) (require :muerte/streams) (require :muerte/restarts) From ffjeld at common-lisp.net Mon Apr 19 22:38:17 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 18:38:17 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18506 Modified Files: defstruct.lisp Log Message: Changed structure-class and defstruct so as to be better integrated with the MOP. This means that the slot-value accessor should now work on structure-objects. Date: Mon Apr 19 18:38:17 2004 Author: ffjeld Index: movitz/losp/muerte/defstruct.lisp diff -u movitz/losp/muerte/defstruct.lisp:1.6 movitz/losp/muerte/defstruct.lisp:1.7 --- movitz/losp/muerte/defstruct.lisp:1.6 Sun Apr 18 19:16:49 2004 +++ movitz/losp/muerte/defstruct.lisp Mon Apr 19 18:38:16 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jan 22 13:10:59 2001 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defstruct.lisp,v 1.6 2004/04/18 23:16:49 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.7 2004/04/19 22:38:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -294,7 +294,11 @@ (slot-number ,slot-number))) (defclass ,struct-name (structure-object) () (:metaclass structure-class) - (:slots ,canonical-slot-descriptions)) + (:slots ,(loop for (name) in canonical-slot-descriptions + as location upfrom 0 + collect (movitz-make-instance 'structure-slot-definition + :name name + :location location)))) ',struct-name)) (list `(progn @@ -332,10 +336,3 @@ (defun structure-object-name (x) (movitz-accessor x movitz-struct name)) -(defmacro with-accessors (slot-entries instance-form &body declarations-and-forms) - (let ((instance-variable (gensym "with-accessors-instance-"))) - `(let ((,instance-variable ,instance-form)) - (declare (ignorable ,instance-variable)) - (symbol-macrolet ,(loop for (variable-name accessor-name) in slot-entries - collecting `(,variable-name (,accessor-name ,instance-variable))) - , at declarations-and-forms)))) From ffjeld at common-lisp.net Mon Apr 19 22:38:22 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 18:38:22 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18714 Modified Files: los-closette-compiler.lisp Log Message: Changed structure-class and defstruct so as to be better integrated with the MOP. This means that the slot-value accessor should now work on structure-objects. Date: Mon Apr 19 18:38:22 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.11 movitz/losp/muerte/los-closette-compiler.lisp:1.12 --- movitz/losp/muerte/los-closette-compiler.lisp:1.11 Sun Feb 15 08:17:55 2004 +++ movitz/losp/muerte/los-closette-compiler.lisp Mon Apr 19 18:38:22 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.11 2004/02/15 13:17:55 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.12 2004/04/19 22:38:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -611,13 +611,13 @@ :direct-superclasses direct-superclasses) class)) - (defun movitz-make-instance (metaclass &rest all-keys) - ;; (warn "movitz-make-instance: ~S ~S" metaclass all-keys) - (when (symbolp metaclass) - (setf metaclass (movitz-find-class metaclass))) - (if (eq metaclass (movitz-find-class 'funcallable-standard-class nil)) - (apply 'movitz-make-instance-funcallable metaclass all-keys) - (let ((instance (std-allocate-instance metaclass))) + (defun movitz-make-instance (class &rest all-keys) + ;; (warn "movitz-make-instance: ~S ~S" class all-keys) + (when (symbolp class) + (setf class (movitz-find-class class))) + (if (eq class (movitz-find-class 'funcallable-standard-class nil)) + (apply 'movitz-make-instance-funcallable class all-keys) + (let ((instance (std-allocate-instance class))) (dolist (slot (class-slots (movitz-class-of instance))) (let ((slot-name (slot-definition-name slot))) (multiple-value-bind (init-key init-value foundp) From ffjeld at common-lisp.net Mon Apr 19 22:38:27 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 18:38:27 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19745 Modified Files: los-closette.lisp Log Message: Changed structure-class and defstruct so as to be better integrated with the MOP. This means that the slot-value accessor should now work on structure-objects. Date: Mon Apr 19 18:38:27 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.8 movitz/losp/muerte/los-closette.lisp:1.9 --- movitz/losp/muerte/los-closette.lisp:1.8 Mon Apr 19 11:06:32 2004 +++ movitz/losp/muerte/los-closette.lisp Mon Apr 19 18:38:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.8 2004/04/19 15:06:32 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.9 2004/04/19 22:38:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1129,7 +1129,14 @@ (defclass structure-class (class) ((slots :initarg :slots - :accessor structure-slots))) + :reader class-slots))) + +(defclass structure-slot-definition (slot-definition) + ((name + :initarg :name) + (location + :initarg :location + :reader structure-slot-location))) (defclass structure-object (t) () (:metaclass structure-class)) @@ -1303,14 +1310,14 @@ (values (slot-missing class object slot-name 'slot-value)) (slot-value-using-class class object slot)))) -(defmethod slot-value-using-class ((class standard-class) object (slot standard-effective-slot-definition)) +(defmethod slot-value-using-class ((class standard-class) object + (slot standard-effective-slot-definition)) (let ((x (standard-instance-access object (slot-definition-location slot)))) (if (eq x (load-global-constant unbound-value)) (slot-unbound class object (slot-definition-name slot)) x))) -(defmethod slot-value-using-class ((class funcallable-standard-class) - object +(defmethod slot-value-using-class ((class funcallable-standard-class) object (slot standard-effective-slot-definition)) (let* ((location (slot-definition-location slot)) (slots (std-gf-instance-slots object)) @@ -1319,6 +1326,9 @@ (slot-unbound class object (slot-definition-name slot)) val))) +(defmethod slot-value-using-class ((class structure-class) object slot) + (structure-ref object (structure-slot-location slot))) + (defun (setf slot-value) (new-value object slot-name) (let* ((class (class-of object)) (slot (find-slot class slot-name))) @@ -1339,6 +1349,9 @@ (slots (std-gf-instance-slots object))) (setf (svref slots location) new-value))) +(defmethod (setf slot-value-using-class) (new-value (class structure-class) object slot) + (setf (structure-ref object (structure-slot-location slot)) new-value)) + (defun slot-boundp (object slot-name) (let* ((class (class-of object)) (slot (find-slot class slot-name))) @@ -1676,13 +1689,12 @@ object) (defmethod print-object ((object structure-object) stream) - (let* ((class (class-of object)) - (slots (mapcar #'car (slot-value class 'slots))) - (position 0)) + (let* ((class (class-of object))) (format stream "#S(~S" (class-name class)) - (dolist (slot slots) - (format stream " :~A ~S" slot (structure-ref object position)) - (incf position)) + (dolist (slot (class-slots class)) + (format stream " :~A ~S" + (symbol-name (slot-definition-name slot)) + (structure-ref object (structure-slot-location slot)))) (write-string ")" stream)) object) From ffjeld at common-lisp.net Mon Apr 19 22:38:33 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 18:38:33 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv19977 Modified Files: more-macros.lisp Log Message: Changed structure-class and defstruct so as to be better integrated with the MOP. This means that the slot-value accessor should now work on structure-objects. Date: Mon Apr 19 18:38:33 2004 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.6 movitz/losp/muerte/more-macros.lisp:1.7 --- movitz/losp/muerte/more-macros.lisp:1.6 Mon Apr 19 16:01:08 2004 +++ movitz/losp/muerte/more-macros.lisp Mon Apr 19 18:38:33 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.6 2004/04/19 20:01:08 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.7 2004/04/19 22:38:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -292,6 +292,14 @@ (defmacro ignore-errors (&body body) `(handler-case (progn , at body) (error (c) (values nil c)))) + +(defmacro with-accessors (slot-entries instance-form &body declarations-and-forms) + (let ((instance-variable (gensym "with-accessors-instance-"))) + `(let ((,instance-variable ,instance-form)) + (declare (ignorable ,instance-variable)) + (symbol-macrolet ,(loop for (variable-name accessor-name) in slot-entries + collecting `(,variable-name (,accessor-name ,instance-variable))) + , at declarations-and-forms)))) (defmacro with-slots (slot-entries instance-form &body declarations-and-forms) (let ((object-var (gensym "with-slots-object-"))) From ffjeld at common-lisp.net Mon Apr 19 22:49:16 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 18:49:16 -0400 Subject: [movitz-cvs] CVS update: Directory change: movitz/losp/tmp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/tmp In directory common-lisp.net:/tmp/cvs-serv12844/tmp Log Message: Directory /project/movitz/cvsroot/movitz/losp/tmp added to the repository Date: Mon Apr 19 18:49:16 2004 Author: ffjeld New directory movitz/losp/tmp added From ffjeld at common-lisp.net Mon Apr 19 22:55:55 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 19 Apr 2004 18:55:55 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/tmp/harddisk.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/tmp In directory common-lisp.net:/tmp/cvs-serv5558 Added Files: harddisk.lisp Log Message: Added Date: Mon Apr 19 18:55:55 2004 Author: ffjeld From ffjeld at common-lisp.net Tue Apr 20 08:32:50 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 20 Apr 2004 04:32:50 -0400 Subject: [movitz-cvs] CVS update: binary-types/binary-types.lisp Message-ID: Update of /project/movitz/cvsroot/binary-types In directory common-lisp.net:/tmp/cvs-serv11619 Modified Files: binary-types.lisp Log Message: I think I simply forgot to check in this. Maybe this fixes the problem with binary-types and CMUCL. Date: Tue Apr 20 04:32:50 2004 Author: ffjeld Index: binary-types/binary-types.lisp diff -u binary-types/binary-types.lisp:1.2 binary-types/binary-types.lisp:1.3 --- binary-types/binary-types.lisp:1.2 Thu Jan 15 08:18:29 2004 +++ binary-types/binary-types.lisp Tue Apr 20 04:32:50 2004 @@ -1,7 +1,7 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 200120001999, 2003-2004, -;;;; Department of Computer Science, University of Troms?, Norway +;;;; Copyright (C) 1999-2004, +;;;; Department of Computer Science, University of Tromsoe, Norway ;;;; ;;;; Filename: binary-types.lisp ;;;; Description: Reading and writing of binary data in streams. @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 19 18:53:57 1999 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: binary-types.lisp,v 1.2 2004/01/15 13:18:29 ffjeld Exp $ +;;;; $Id: binary-types.lisp,v 1.3 2004/04/20 08:32:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -421,14 +421,15 @@ ;;;(defun record-slot-type (s) (second s)) ;;;(defun record-slot-on-write (s) (third s)) -(defstruct record-slot - name - type - map-write - map-read - map-read-delayed - hidden-read-slot - tags) ; for map-read-delayed, the binary value is stored here. +(eval-when (:load-toplevel :compile-toplevel) + (defstruct record-slot + name + type + map-write + map-read + map-read-delayed + hidden-read-slot + tags)) ; for map-read-delayed, the binary value is stored here. (defmethod make-load-form ((object record-slot) &optional environment) (declare (ignore environment)) From ffjeld at common-lisp.net Tue Apr 20 23:04:13 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 20 Apr 2004 19:04:13 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8128 Modified Files: compiler.lisp Log Message: Worked on the peephole optimizer a bit. Date: Tue Apr 20 19:04:12 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.56 movitz/compiler.lisp:1.57 --- movitz/compiler.lisp:1.56 Mon Apr 19 16:34:55 2004 +++ movitz/compiler.lisp Tue Apr 20 19:04:12 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.56 2004/04/19 20:34:55 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.57 2004/04/20 23:04:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1417,7 +1417,6 @@ (and (or (not dest) (equal dest (second (twop-p c op)))) (first (twop-p c op))))) - #+ignore (isrc (c) (let ((c (ignore-instruction-prefixes c))) (ecase (length (cdr c)) @@ -1486,6 +1485,25 @@ (and (member register '(:edx)) (member (global-funcall-p i) '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx))))))) + (operand-register-indirect-p (operand register) + (and (consp operand) + (tree-search operand register))) + (doesnt-read-register-p (i register) + (let ((i (ignore-instruction-prefixes i))) + (or (symbolp i) + (and (simple-instruction-p i) + (if (member (instruction-is i) '(:movl)) + (and (not (eq register (twop-src i))) + (not (operand-register-indirect-p (twop-src i) register)) + (not (operand-register-indirect-p (twop-dst i) register))) + (not (or (eq register (isrc i)) + (operand-register-indirect-p (isrc i) register) + (eq register (idst i)) + (operand-register-indirect-p (idst i) register))))) + (instruction-is i :frame-map) + (and (member register '(:edx)) + (member (global-funcall-p i) + '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx)))))) (register-operand (op) (and (member op '(:eax :ebx :ecx :edx :edi)) op)) @@ -1901,6 +1919,43 @@ (append (list i3 i i2) `((:movl ,reg ,(twop-dst i3))))) next-pc (cdddr pc)))) + ;; ((:movl ) label (:movl )) + ;; => (label (:movl )) + ((and (instruction-is i :movl) + (or (symbolp i2) + (and (not (branch-instruction-label i2)) + (symbolp (twop-dst i)) + (doesnt-read-register-p i2 (twop-dst i)))) + (instruction-is i3 :frame-map) + (instruction-is i4 :movl) + (equal (twop-dst i) (twop-dst i4)) + (not (and (symbolp (twop-dst i)) + (operand-register-indirect-p (twop-src i4) + (twop-dst i))))) + (setq p (list i2 i3 i4) + next-pc (nthcdr 4 pc)) + (explain nil "Removed redundant store before ~A: ~A" + i2 (subseq pc 0 4))) + ((and (instruction-is i :movl) + (not (branch-instruction-label i2)) + (symbolp (twop-dst i)) + (doesnt-read-register-p i2 (twop-dst i)) + (instruction-is i3 :movl) + (equal (twop-dst i) (twop-dst i3)) + (not (and (symbolp (twop-dst i)) + (operand-register-indirect-p (twop-src i3) + (twop-dst i))))) + (setq p (list i2 i3) + next-pc (nthcdr 3 pc)) + (explain nil "Removed redundant store before ~A: ~A" + i2 (subseq pc 0 3))) + ((and (member (instruction-is i) + '(:cmpl :cmpb :cmpw :testl :testb :testw)) + (member (instruction-is i2) + '(:cmpl :cmpb :cmpw :testl :testb :testw))) + (setq p (list i2) + next-pc (nthcdr 2 pc)) + (explain nil "Trimmed double test: ~A" (subseq pc 0 4))) ;; ((:jmp x) ...(no labels).... x ..) ;; => (x ...) ((let ((x (branch-instruction-label i t nil))) @@ -1940,7 +1995,9 @@ (null (find-branches-to-label unoptimized-code i)) (not (member i keep-labels))) (setq p nil - next-pc (cdr pc)) + next-pc (if (instruction-is i2 :frame-map) + (cddr pc) + (cdr pc))) (explain nil "unused label: ~S" i)) ;; ((:jcc 'label) (:jmp 'y) label) => ((:jncc 'y) label) ((and (branch-instruction-label i) From ffjeld at common-lisp.net Wed Apr 21 14:00:17 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 21 Apr 2004 10:00:17 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26391 Modified Files: symbols.lisp Log Message: Fixed a horrible bug in %create-symbol. Date: Wed Apr 21 10:00:16 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.11 movitz/losp/muerte/symbols.lisp:1.12 --- movitz/losp/muerte/symbols.lisp:1.11 Fri Apr 16 19:36:40 2004 +++ movitz/losp/muerte/symbols.lisp Wed Apr 21 10:00:15 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.11 2004/04/16 23:36:40 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.12 2004/04/21 14:00:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -149,7 +149,9 @@ (let ((symbol (%word-offset (malloc-clumps 3) 1))) (setf-movitz-accessor (symbol movitz-symbol package) package) (setf-movitz-accessor (symbol movitz-symbol name) name) - (setf-movitz-accessor (symbol movitz-symbol hash-key) (sxhash name)) + (setf (memref symbol #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::hash-key) + 0 :unsigned-byte16) + (sxhash name)) (setf (symbol-flags symbol) flags (symbol-plist symbol) plist (symbol-function symbol) function From ffjeld at common-lisp.net Wed Apr 21 15:05:40 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 21 Apr 2004 11:05:40 -0400 Subject: [movitz-cvs] CVS update: movitz/assembly-syntax.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8352 Modified Files: assembly-syntax.lisp Log Message: Make assembly-macroexpand not barf on non-proper lists. Date: Wed Apr 21 11:05:40 2004 Author: ffjeld Index: movitz/assembly-syntax.lisp diff -u movitz/assembly-syntax.lisp:1.2 movitz/assembly-syntax.lisp:1.3 --- movitz/assembly-syntax.lisp:1.2 Mon Jan 19 06:23:41 2004 +++ movitz/assembly-syntax.lisp Wed Apr 21 11:05:39 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 17:34:37 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: assembly-syntax.lisp,v 1.2 2004/01/19 11:23:41 ffjeld Exp $ +;;;; $Id: assembly-syntax.lisp,v 1.3 2004/04/21 15:05:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,29 +25,21 @@ (setf (gethash symbol (assembly-macro-environment-expanders amenv)) expander)) -;;;(defun assembly-macroexpand (prg amenv) -;;; (cond -;;; ((and (consp prg) (symbolp (car prg))) -;;; (let ((expander (assembly-macro-expander (car prg) amenv))) -;;; (if expander -;;; (assembly-macroexpand (funcall expander prg) amenv) -;;; #0=(cons (assembly-macroexpand (car prg) amenv) -;;; (assembly-macroexpand (cdr prg) amenv))))) -;;; ((consp prg) #0#) -;;; (t prg))) - (defun assembly-macroexpand (prg amenv) - (loop for p in prg - as expander = (and (consp p) - (symbolp (car p)) - (assembly-macro-expander (car p) amenv)) - if expander - append (funcall expander p) - else if (consp p) - append (list (assembly-macroexpand p amenv)) - else append (list p))) - -;;;(defmacro with-assembly-syntax (&body body) -;;; `(let ((*readtable* (copy-readtable nil))) -;;; (set-dispatch-macro-character + (let* ((fix-tail nil) + (new-prg + (loop for (p . tail) on prg + as expander = (and (consp p) + (symbolp (car p)) + (assembly-macro-expander (car p) amenv)) + if expander + append (funcall expander p) + else if (consp p) + append (list (assembly-macroexpand p amenv)) + else append (list p) + unless (listp tail) + do (setf fix-tail tail)))) + (when fix-tail + (setf (cdr (last new-prg)) fix-tail)) + new-prg)) From ffjeld at common-lisp.net Wed Apr 21 15:06:16 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 21 Apr 2004 11:06:16 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10632 Modified Files: compiler.lisp Log Message: Removed bad check-type. Date: Wed Apr 21 11:06:16 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.57 movitz/compiler.lisp:1.58 --- movitz/compiler.lisp:1.57 Tue Apr 20 19:04:12 2004 +++ movitz/compiler.lisp Wed Apr 21 11:06:16 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.57 2004/04/20 23:04:12 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.58 2004/04/21 15:06:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5831,7 +5831,6 @@ (define-extended-code-expander :endp (instruction funobj frame-map) (destructuring-bind (cell result-mode) (cdr instruction) - (check-type cell lexical-binding) (let* ((binding (binding-target (ensure-local-binding (binding-target cell) funobj))) (location (new-binding-location (binding-target binding) frame-map)) (binding-is-list-p (binding-store-subtypep binding 'list)) @@ -5844,11 +5843,6 @@ (member location '(:eax :ebx :ecx :edx))) (make-result-and-returns-glue result-mode :boolean-zf=1 `((:cmpl :edi ,location)))) -;;; ((and binding-is-list-p -;;; (eq (result-mode-type result-mode) -;;; :boolean-branch-on-false)) -;;; (cond -;;; ((member location '(:eax :ebx :ecx :edx)) ((eq :boolean-branch-on-true (result-mode-type result-mode)) (let ((tmp-register (or tmp-register :ecx))) (append (make-load-lexical binding From ffjeld at common-lisp.net Wed Apr 21 15:06:50 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 21 Apr 2004 11:06:50 -0400 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11406 Modified Files: image.lisp Log Message: Minor edit. Date: Wed Apr 21 11:06:50 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.26 movitz/image.lisp:1.27 --- movitz/image.lisp:1.26 Mon Apr 19 11:06:21 2004 +++ movitz/image.lisp Wed Apr 21 11:06:50 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.26 2004/04/19 15:06:21 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.27 2004/04/21 15:06:50 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -549,7 +549,8 @@ muerte:run-time-context muerte.mop:standard-effective-slot-definition muerte.mop:funcallable-standard-class - muerte:basic-restart)) + muerte:basic-restart + muerte:illegal-object)) (defun class-object-offset (name) (+ (bt:slot-offset 'movitz-vector 'data) From ffjeld at common-lisp.net Wed Apr 21 15:07:28 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 21 Apr 2004 11:07:28 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12850 Modified Files: los-closette.lisp Log Message: Added class illegal-object. Date: Wed Apr 21 11:07:27 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.9 movitz/losp/muerte/los-closette.lisp:1.10 --- movitz/losp/muerte/los-closette.lisp:1.9 Mon Apr 19 18:38:27 2004 +++ movitz/losp/muerte/los-closette.lisp Wed Apr 21 11:07:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.9 2004/04/19 22:38:27 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.10 2004/04/21 15:07:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -227,44 +227,12 @@ (defun class-of (object) (class-of object)) ; compiler-macro -#+ignore -(defun class-of (object) - (typecase object - (std-instance - (movitz-accessor object movitz-std-instance class)) - (standard-gf-instance - (movitz-accessor object movitz-funobj-standard-gf standard-gf-class)) - (null - (find-class 'null)) - (cons - (find-class 'cons)) - (symbol - (find-class 'symbol)) - (fixnum - (find-class 'fixnum)) - (vector - (find-class 'vector)) - (compiled-function - (find-class 'function)) - (hash-table - (find-class 'hash-table)) - (package - (find-class 'package)) - (structure-object - (find-class 'structure-object)) - (t (warn "Don't know the class of ~Z!" object) - (find-class t)))) - (defun subclassp (c1 c2) (not (null (find c2 (class-precedence-list c1))))) ;;; -;;; -;;; -;;; -;;; -;;; ;;; Generic function stuff +;;; ;;; Several tedious functions for analyzing lambda lists @@ -1025,6 +993,8 @@ (defclass float (real) () (:metaclass built-in-class)) (defclass complex (number) () (:metaclass built-in-class)) +(defclass illegal-object (t) () (:metaclass built-in-class)) + (defclass run-time-context (t) () (:metaclass built-in-class) @@ -1144,7 +1114,7 @@ (declare (dynamic-extent init-args)) (let ((class (if (symbolp class) (find-class class nil) class))) (check-type class structure-class) - (let* ((slots (structure-slots class)) + (let* ((slots (class-slots class)) (num-slots (length slots)) (struct (malloc-words num-slots))) (setf (memref struct #.(bt:slot-offset 'movitz::movitz-struct 'movitz::name) @@ -1717,6 +1687,10 @@ (defmethod print-object ((x run-time-context) stream) (print-unreadable-object (x stream :type t :identity t) (format stream " ~S" (%run-time-context-slot 'name x))) + x) + +(defmethod print-object ((x illegal-object) stream) + (print-unreadable-object (x stream :type t :identity t)) x) ;;; From ffjeld at common-lisp.net Wed Apr 21 15:07:48 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 21 Apr 2004 11:07:48 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13349 Modified Files: print.lisp Log Message: Minor edits. Date: Wed Apr 21 11:07:48 2004 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.7 movitz/losp/muerte/print.lisp:1.8 --- movitz/losp/muerte/print.lisp:1.7 Tue Apr 13 11:15:55 2004 +++ movitz/losp/muerte/print.lisp Wed Apr 21 11:07:48 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.7 2004/04/13 15:15:55 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.8 2004/04/21 15:07:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -202,8 +202,7 @@ (null (write-string (symbol-name nil) stream)) ((or cons tag5) - (let ((level *print-level*) - (length *print-length*)) + (let ((level *print-level*)) (cond ((and level (minusp level)) (write-char #\# stream)) @@ -227,7 +226,7 @@ (write (cdr c)) (write-char #\) stream))))))) (write-char #\( stream) - (write-cons object stream length)))))) + (write-cons object stream *print-length*)))))) (integer (write-integer object stream *print-base* *print-radix*)) (string From ffjeld at common-lisp.net Wed Apr 21 15:08:36 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 21 Apr 2004 11:08:36 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16271 Modified Files: primitive-functions.lisp Log Message: Various minor fixes. Date: Wed Apr 21 11:08:36 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.15 movitz/losp/muerte/primitive-functions.lisp:1.16 --- movitz/losp/muerte/primitive-functions.lisp:1.15 Mon Apr 19 15:49:11 2004 +++ movitz/losp/muerte/primitive-functions.lisp Wed Apr 21 11:08:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.15 2004/04/19 19:49:11 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.16 2004/04/21 15:08:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -30,33 +30,29 @@ "Call a function with 1 argument" (with-inline-assembly (:returns :nothing) (:movb 1 :cl) - (:jmp (:esi -6)))) + (:jmp (:esi #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector))))) (define-primitive-function trampoline-funcall%2op () "Call a function with 2 arguments" (with-inline-assembly (:returns :nothing) (:movb 2 :cl) - (:jmp (:esi -6)))) + (:jmp (:esi #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector))))) (define-primitive-function trampoline-funcall%3op () "Call a function with 3 arguments" (with-inline-assembly (:returns :nothing) -;;; (:xorl :ecx :ecx) -;;; (:movb 2 :cl) (:movb 3 :cl) - (:jmp (:esi -6)))) + (:jmp (:esi #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector))))) (define-primitive-function trampoline-cl-dispatch-1or2 () "Jump to the entry-point designated by :cl, which must be 1 or 2." (with-inline-assembly (:returns :nothing) - (:cmpb 1 :cl) - (:jne 'not-one) - (:jmp (:esi #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector%1op))) - not-one - (:cmpb 2 :cl) - (:jne 'not-two) - (:jmp (:esi #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector%2op))) - not-two + (:subb 1 :cl) ; 1 or 2 => 0 or 1 + (:testb #xfe :cl) + (:jnz 'mismatch) + (:jmp (:esi (:ecx 4) #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector%1op))) + mismatch + (:addb 1 :cl) (:int 100))) (define-primitive-function no-code-vector () @@ -246,10 +242,7 @@ (:jecxz 'no-stack-binding) (:cmpl :eax (:ecx)) (:je 'success) -;;; (:locally (:movl (:edi (:edi-offset stack-top)) :edx)) search-loop -;;; (:cmpl :edx (:ecx 12)) -;;; (:jnc '(:sub-program () (:int 97))) (:movl (:ecx 12) :ecx) ; parent (:jecxz 'no-stack-binding) (:cmpl :eax (:ecx)) ; compare name @@ -277,10 +270,7 @@ (:jecxz 'no-binding) (:cmpl :eax (:ecx)) (:je 'success) -;;; (:locally (:movl (:edi (:edi-offset stack-top)) :edx)) search-loop -;;; (:cmpl :edx (:ecx 12)) -;;; (:jnc '(:sub-program () (:int 97))) (:movl (:ecx 12) :ecx) ; parent (:jecxz 'no-binding) (:cmpl :eax (:ecx)) ; compare name @@ -555,7 +545,8 @@ (define-primitive-function fast-class-of-tag3 () "Return the class of a tag3 object." (with-inline-assembly (:returns :multiple-values) - (:int 64) + (:globally (:movl (:edi (:edi-offset classes)) :eax)) + (:movl (:eax #.(movitz::class-object-offset 'illegal-object)) :eax) (:ret))) (define-primitive-function fast-class-of-character () @@ -572,10 +563,14 @@ (define-primitive-function fast-class-of-null () "Return the class of a nil object." (with-inline-assembly (:returns :multiple-values) + (:globally (:movl (:edi (:edi-offset classes)) :ebx)) (:cmpl :edi :eax) - (:jne '(:sub-program () (:int 64))) - (:globally (:movl (:edi (:edi-offset classes)) :eax)) - (:movl (:eax #.(movitz::class-object-offset 'null)) :eax) + (:je 'null) + (:movl (:ebx #.(movitz::class-object-offset 'illegal-object)) :eax) + (:jmp 'not-null) + null + (:movl (:ebx #.(movitz::class-object-offset 'null)) :eax) + not-null (:ret))) (define-primitive-function fast-class-of-other () @@ -626,13 +621,7 @@ (find-class 'fixnum)) (basic-restart (find-class 'basic-restart)) - (tag6 - (error "Don't know the class of ~Z with other-type #x~X." - object (with-inline-assembly (:returns :untagged-fixnum-ecx) - (:compile-form (:result-mode :eax) object) - (:movzxb (:eax -2) :ecx)))) - (t (error "Don't know the class of the word ~Z!" object) - (find-class t)))) + (t (find-class 'illegal-object)))) (define-primitive-function push-current-values () "Push all current return-values on the stack. And, return number From ffjeld at common-lisp.net Wed Apr 21 15:09:25 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 21 Apr 2004 11:09:25 -0400 Subject: [movitz-cvs] CVS update: movitz/movitz.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24597 Modified Files: movitz.lisp Log Message: Added syntax #{...} for arrays specialized to (unsigned-byte 8). Date: Wed Apr 21 11:09:25 2004 Author: ffjeld Index: movitz/movitz.lisp diff -u movitz/movitz.lisp:1.6 movitz/movitz.lisp:1.7 --- movitz/movitz.lisp:1.6 Wed Apr 14 08:37:23 2004 +++ movitz/movitz.lisp Wed Apr 21 11:09:25 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:52:58 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: movitz.lisp,v 1.6 2004/04/14 12:37:23 ffjeld Exp $ +;;;; $Id: movitz.lisp,v 1.7 2004/04/21 15:09:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -61,6 +61,13 @@ (declare (ignore subchar arg)) (list 'muerte.common-lisp::function (read stream t nil t)))) + (set-dispatch-macro-character #\# #\{ + (lambda (stream subchar arg) + (declare (ignore subchar arg)) + (let ((data (read-delimited-list #\} stream))) + (make-movitz-vector (length data) + :element-type 'movitz-unboxed-integer-u8 + :initial-contents data)))) (set-macro-character #\` (lambda (stream char) (declare (ignore char)) (let ((*bq-level* (1+ *bq-level*))) From ffjeld at common-lisp.net Wed Apr 21 16:00:25 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 21 Apr 2004 12:00:25 -0400 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv14991 Modified Files: packages.lisp Log Message: More symbols. Date: Wed Apr 21 12:00:25 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.20 movitz/packages.lisp:1.21 --- movitz/packages.lisp:1.20 Mon Apr 19 11:04:32 2004 +++ movitz/packages.lisp Wed Apr 21 12:00:25 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.20 2004/04/19 15:04:32 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.21 2004/04/21 16:00:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1191,6 +1191,7 @@ #:vector-u32 #:pointer #:basic-restart + #:illegal-object #:run-time-context make-funobj From ffjeld at common-lisp.net Wed Apr 21 16:22:56 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 21 Apr 2004 12:22:56 -0400 Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv1444 Modified Files: storage-types.lisp Log Message: Re-worked a bit how hash-tables are translated to movitz. Increased their size quite a bit, so as to reduce the number of collisions. Date: Wed Apr 21 12:22:56 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.15 movitz/storage-types.lisp:1.16 --- movitz/storage-types.lisp:1.15 Mon Mar 29 09:35:17 2004 +++ movitz/storage-types.lisp Wed Apr 21 12:22:56 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.15 2004/03/29 14:35:17 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.16 2004/04/21 16:22:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1126,7 +1126,7 @@ (defun make-movitz-hash-table (lisp-hash) (let* ((undef (movitz-read +undefined-hash-key+)) - (hash-size (* 4 (max 8 (hash-table-count lisp-hash)))) + (hash-size (* 2 (truncate (+ 25 (hash-table-count lisp-hash)) 1/3))) (bucket-data (make-array hash-size :initial-element undef))) (multiple-value-bind (hash-test hash-sxhash) (ecase (hash-table-test lisp-hash) @@ -1139,8 +1139,8 @@ do (loop for pos = (rem (* 2 (movitz-sxhash movitz-key)) hash-size) then (rem (+ 2 pos) hash-size) until (eq undef (svref bucket-data pos)) -;;; do (warn "Hash collision at ~D of ~D: ~S ~S!" -;;; pos hash-size movitz-key (elt bucket-list pos)) +;;; do (warn "Hash collision at ~D of ~D: ~S ~S!" +;;; pos hash-size movitz-key (elt bucket-data pos)) ;;; finally (warn "Hash: pos ~D: ~S ~S" pos movitz-key movitz-value) ;;; finally (when (equal "NIL" key) ;;; (warn "key: ~S, value: ~S pos: ~S" movitz-key movitz-value pos)) @@ -1149,7 +1149,7 @@ (let* ((bucket (make-movitz-vector hash-size :initial-contents bucket-data)) (lh (make-instance 'movitz-struct :name (movitz-read 'muerte::hash-table) - :length 2 + :length 3 :slot-values (list hash-test ; test-function bucket hash-sxhash)))) @@ -1160,7 +1160,7 @@ (assert (= 3 (length (movitz-struct-slot-values movitz-hash)))) (let* ((undef (movitz-read +undefined-hash-key+)) (old-bucket (second (movitz-struct-slot-values movitz-hash))) - (hash-size (* 2 (truncate (hash-table-count lisp-hash) 2/3))) + (hash-size (* 2 (truncate (+ 25 (hash-table-count lisp-hash)) 1/3))) (bucket-data (or (and old-bucket (= (length (movitz-vector-symbolic-data old-bucket)) hash-size) @@ -1178,12 +1178,14 @@ then (rem (+ 2 pos) hash-size) until (eq undef (svref bucket-data pos)) ;;; do (warn "Hash collision at ~D of ~D: ~S ~S!" -;;; pos hash-size movitz-key (elt bucket-list pos)) +;;; pos hash-size movitz-key (elt bucket-data pos)) ;;; finally (warn "Hash: pos ~D: ~S ~S" pos movitz-key movitz-value) ;;; finally (when (equal "NIL" key) ;;; (warn "key: ~S, value: ~S pos: ~S" movitz-key movitz-value pos)) - finally (setf (svref bucket-data pos) movitz-key - (svref bucket-data (1+ pos)) movitz-value))) + finally + (setf (svref bucket-data pos) movitz-key + (svref bucket-data (1+ pos)) movitz-value))) + (setf *foo* bucket-data) (setf (first (movitz-struct-slot-values movitz-hash)) hash-test (second (movitz-struct-slot-values movitz-hash)) (movitz-read bucket-data) (third (movitz-struct-slot-values movitz-hash)) hash-sxhash) From ffjeld at common-lisp.net Wed Apr 21 16:24:05 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 21 Apr 2004 12:24:05 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/package.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv14432 Modified Files: package.lisp Log Message: Added some more VGA interfacing. Try e.g. (set-textmode +vga-state-80x50+). Date: Wed Apr 21 12:24:05 2004 Author: ffjeld Index: movitz/losp/x86-pc/package.lisp diff -u movitz/losp/x86-pc/package.lisp:1.3 movitz/losp/x86-pc/package.lisp:1.4 --- movitz/losp/x86-pc/package.lisp:1.3 Mon Jan 19 06:23:52 2004 +++ movitz/losp/x86-pc/package.lisp Wed Apr 21 12:24:05 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 20:30:28 2001 ;;;; -;;;; $Id: package.lisp,v 1.3 2004/01/19 11:23:52 ffjeld Exp $ +;;;; $Id: package.lisp,v 1.4 2004/04/21 16:24:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -51,7 +51,14 @@ #:+pit8253-nanosecond-period+ #:textmode-console - #:vga-text-console + #:vga-text-console + #:set-textmode + #:+vga-state-80x25+ + #:+vga-state-80x50+ + #:+vga-state-40x25+ + #:+vga-state-40x50+ + #:+vga-state-90x30+ + #:+vga-state-90x60+ #:pic8259-irq-mask #:pic8259-end-of-interrupt From ffjeld at common-lisp.net Wed Apr 21 16:24:10 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 21 Apr 2004 12:24:10 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/textmode.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv14722 Modified Files: textmode.lisp Log Message: Added some more VGA interfacing. Try e.g. (set-textmode +vga-state-80x50+). Date: Wed Apr 21 12:24:10 2004 Author: ffjeld Index: movitz/losp/x86-pc/textmode.lisp diff -u movitz/losp/x86-pc/textmode.lisp:1.5 movitz/losp/x86-pc/textmode.lisp:1.6 --- movitz/losp/x86-pc/textmode.lisp:1.5 Fri Apr 16 15:17:22 2004 +++ movitz/losp/x86-pc/textmode.lisp Wed Apr 21 12:24:10 2004 @@ -4,12 +4,12 @@ ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: textmode.lisp -;;;; Description: A primitive 80x25 text-mode console driver. +;;;; Description: A primitive VGA text-mode console driver. ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Nov 9 15:38:56 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: textmode.lisp,v 1.5 2004/04/16 19:17:22 ffjeld Exp $ +;;;; $Id: textmode.lisp,v 1.6 2004/04/21 16:24:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -26,22 +26,22 @@ (define-global-variable *screen* (vga-memory-map)) +(define-global-variable *screen-width* + (vga-horizontal-display-end)) + +(define-global-variable *screen-stride* + (vga-horizontal-display-end)) + (define-global-variable *cursor-x* - (rem (vga-cursor-location) 80)) + (rem (vga-cursor-location) *screen-stride*)) (define-global-variable *cursor-y* - (truncate (vga-cursor-location) 80)) - -(define-global-variable *screen-width* - (vga-horizontal-display-end)) + (truncate (vga-cursor-location) *screen-stride*)) (define-global-variable *screen-height* (truncate (vga-vertical-display-end) (vga-character-height))) -(define-global-variable *screen-stride* - (vga-horizontal-display-end)) - (defun move-vga-cursor (x y) (let ((dest (+ x (* y *screen-stride*)))) (setf (vga-cursor-location) dest))) @@ -102,26 +102,26 @@ nil) (defun textmode-copy-line (destination source count) - (check-type count (integer 0 511)) + (check-type count (and (integer 0 511) (satisfies evenp))) (check-type source (unsigned-byte 20)) (check-type destination (unsigned-byte 20)) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :eax) source) - (:compile-form (:result-mode :ebx) destination) - (:compile-form (:result-mode :edx) count) - (:andl #x-16 :eax) - (:andl #x-16 :ebx) - (:andl #x-8 :edx) + (:compile-form (:result-mode :edx) destination) + (:compile-form (:result-mode :ebx) count) + (:std) ; Only EBX is now (potential) GC root + (:andl #x-8 :ebx) ; ..so make sure EBX is a fixnum (:shrl 2 :eax) - (:shrl 2 :ebx) - (:shrl 1 :edx) + (:shrl 2 :edx) + (:shrl 1 :ebx) (:jz 'end-copy-loop) copy-loop - ((:gs-override) :movl (:eax :edx -4) :ecx) - ((:gs-override) :movl :ecx (:ebx :edx -4)) - (:subl 4 :edx) + ((:gs-override) :movl (:eax :ebx -4) :ecx) + ((:gs-override) :movl :ecx (:edx :ebx -4)) + (:subl 4 :ebx) (:ja 'copy-loop) - end-copy-loop)) + end-copy-loop + (:cld))) (defun textmode-scroll-down () (declare (special muerte.lib::*scroll-offset*)) @@ -133,12 +133,12 @@ do (textmode-copy-line dst src *screen-width*))) (defun textmode-clear-line (from-column line) - (let ((dest (+ *screen* (* line 80 2) (* from-column 2)))) - (dotimes (i (- 80 from-column)) + (let ((dest (+ *screen* (* line *screen-width* 2) (* from-column 2)))) + (dotimes (i (- *screen-width* from-column)) (setf (memref-int dest 0 i :unsigned-byte16 t) #x0720)))) (defun write-word (word) - (let ((dest (+ *screen* (* *cursor-x* 2) (* *cursor-y* 160)))) + (let ((dest (+ *screen* (* *cursor-x* 2) (* *cursor-y* *screen-width* 2)))) (setf (memref-int dest 0 0 :unsigned-byte16 t) #x0723 (memref-int dest 0 1 :unsigned-byte16 t) #x0778) (write-word-lowlevel word (+ dest 4)) @@ -238,3 +238,22 @@ (cursor-x (setf (cursor-column) (car args))) (cursor-y (setf (cursor-row) (car args))))) (t (error "Unknown op: ~S" op)))))) + + +(defun set-textmode (mode-state) + (setf (vga-state) mode-state) + (ecase (vga-character-height) + (8 (write-font +vga-font-8x8+ 8)) + (16 (write-font +vga-font-8x16+ 16))) + (setf *screen-width* + (vga-horizontal-display-end)) + (setf *screen-height* + (truncate (vga-vertical-display-end) + (vga-character-height))) + (setf *screen-stride* + (vga-horizontal-display-end)) + (setf *cursor-x* + (min (1- *screen-width*) *cursor-x*)) + (setf *cursor-y* + (min (1- *screen-height*) *cursor-y*)) + (values)) From ffjeld at common-lisp.net Wed Apr 21 16:24:16 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 21 Apr 2004 12:24:16 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/vga.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv14981 Modified Files: vga.lisp Log Message: Added some more VGA interfacing. Try e.g. (set-textmode +vga-state-80x50+). Date: Wed Apr 21 12:24:16 2004 Author: ffjeld Index: movitz/losp/x86-pc/vga.lisp diff -u movitz/losp/x86-pc/vga.lisp:1.4 movitz/losp/x86-pc/vga.lisp:1.5 --- movitz/losp/x86-pc/vga.lisp:1.4 Fri Apr 16 15:17:55 2004 +++ movitz/losp/x86-pc/vga.lisp Wed Apr 21 12:24:16 2004 @@ -6,11 +6,11 @@ ;;;; For distribution policy, see the accompanying file COPYING. ;;;; ;;;; Filename: vga.lisp -;;;; Description: +;;;; Description: Low-level VGA interfacing. ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 25 14:08:20 2001 ;;;; -;;;; $Id: vga.lisp,v 1.4 2004/04/16 19:17:55 ffjeld Exp $ +;;;; $Id: vga.lisp,v 1.5 2004/04/21 16:24:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -19,6 +19,11 @@ (in-package muerte.x86-pc) +(defconstant +vga-base+ #x3c0) + +(defmacro vga-port (register) + `(io-register8 +vga-base+ ,register)) + (defun vga-crt-controller-register (register) (let* ((address-register (if (logbitp 0 (io-port #x3cc :unsigned-byte8)) #x3d4 #x3b4)) (data-register (1+ address-register))) @@ -39,6 +44,24 @@ (setf (io-port #x3ce :unsigned-byte8) register (io-port #x3cf :unsigned-byte8) value)) +(defun vga-sequencer-register (register) + (setf (vga-port 4) register) + (vga-port 5)) + +(defun (setf vga-sequencer-register) (value register) + (setf (vga-port 4) register + (vga-port 5) value)) + +(defun vga-attribute-register (register) + (vga-port #x1a) + (setf (vga-port 0) register) + (vga-port 1)) + +(defun (setf vga-attribute-register) (value register) + (vga-port #x1a) + (setf (vga-port 0) register + (vga-port 0) value)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun (setf vga-cursor-location) (value) @@ -74,3 +97,793 @@ (defun vga-character-height () (1+ (ldb (byte 5 0) (vga-crt-controller-register 9)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; VGA stuff ported from http://my.execpc.com/CE/AC/geezer/osd/graphics/modes.c + +(defconstant +vga-state-80x25+ + '((:misc . #x67) + (:sequencer + #x03 #x00 #x03 #x00 #x02) + (:crtc + #x5F #x4F #x50 #x82 #x55 #x81 #xBF #x1F + #x00 #x4F #x0D #x0E #x00 #x00 #x00 #x50 + #x9C #x0E #x8F #x28 #x1F #x96 #xB9 #xA3 + #xFF) + (:graphics + #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 + #xFF) + (:attribute + #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 + #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F + #x0C #x00 #x0F #x08 #x00))) + +(defconstant +vga-state-80x50+ + '((:misc . #x67) + (:sequencer + #x03 #x00 #x03 #x00 #x02) + (:crtc + #x5F #x4F #x50 #x82 #x55 #x81 #xBF #x1F + #x00 #x47 #x06 #x07 #x00 #x00 #x01 #x40 + #x9C #x8E #x8F #x28 #x1F #x96 #xB9 #xA3 + #xFF) + (:graphics + #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 + #xFF) + (:attribute + #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 + #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F + #x0C #x00 #x0F #x08 #x00))) + +(defconstant +vga-state-40x25+ + '((:misc . #x67) + (:sequencer + #x03 #x08 #x03 #x00 #x02) + (:crtc + #x2D #x27 #x28 #x90 #x2B #xA0 #xBF #x1F + #x00 #x4F #x0D #x0E #x00 #x00 #x00 #xA0 + #x9C #x8E #x8F #x14 #x1F #x96 #xB9 #xA3 + #xFF) + (:graphics + #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 + #xFF) + (:attribute + #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 + #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F + #x0C #x00 #x0F #x08 #x00))) + +(defconstant +vga-state-40x50+ + '((:misc . #x67) + (:sequencer + #x03 #x08 #x03 #x00 #x02) + (:crtc + #x2D #x27 #x28 #x90 #x2B #xA0 #xBF #x1F + #x00 #x47 #x06 #x07 #x00 #x00 #x04 #x60 + #x9C #x8E #x8F #x14 #x1F #x96 #xB9 #xA3 + #xFF) + (:graphics + #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 + #xFF) + (:attribute + #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 + #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F + #x0C #x00 #x0F #x08 #x00))) + +(defconstant +vga-state-90x30+ + '((:misc . #xE7) + (:sequencer + #x03 #x01 #x03 #x00 #x02) + (:crtc + #x6B #x59 #x5A #x82 #x60 #x8D #x0B #x3E + #x00 #x4F #x0D #x0E #x00 #x00 #x00 #x00 + #xEA #x0C #xDF #x2D #x10 #xE8 #x05 #xA3 + #xFF) + (:graphics + #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 + #xFF) + (:attribute + #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 + #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F + #x0C #x00 #x0F #x08 #x00))) + +(defconstant +vga-state-90x60+ + '((:misc . #xE7) + (:sequencer + #x03 #x01 #x03 #x00 #x02) + (:crtc + #x6B #x59 #x5A #x82 #x60 #x8D #x0B #x3E + #x00 #x47 #x06 #x07 #x00 #x00 #x00 #x00 + #xEA #x0C #xDF #x2D #x08 #xE8 #x05 #xA3 + #xFF) + (:graphics + #x00 #x00 #x00 #x00 #x00 #x10 #x0E #x00 + #xFF) + (:attribute + #x00 #x01 #x02 #x03 #x04 #x05 #x14 #x07 + #x38 #x39 #x3A #x3B #x3C #x3D #x3E #x3F + #x0C #x00 #x0F #x08 #x00))) + + +(defconstant +vga-misc-read+ #x0c) +(defconstant +vga-misc-write+ #x02) + +(defconstant VGA-MISC-WRITE #x3C2) +(defconstant VGA-AC-INDEX #x3C0) +(defconstant VGA-AC-WRITE #x3C0) +(defconstant VGA-AC-READ #x3C1) +(defconstant VGA-SEQ-INDEX #x3C4) +(defconstant VGA-SEQ-DATA #x3C5) +(defconstant VGA-DAC-READ-INDEX #x3C7) +(defconstant VGA-DAC-WRITE-INDEX #x3C8) +(defconstant VGA-DAC-DATA #x3C9) +(defconstant VGA-MISC-READ #x3CC) +(defconstant VGA-GC-INDEX #x3CE) +(defconstant VGA-GC-DATA #x3CF) +(defconstant VGA-CRTC-INDEX #x3D4) +(defconstant VGA-CRTC-DATA #x3D5) +(defconstant VGA-INSTAT-READ #x3DA) + +(defun vga-state () + "Dump the state of the VGA register set." + (prog1 + (list + (cons :misc + (vga-port +vga-misc-read+)) + (cons :sequencer + (loop for i from 0 below 5 + collect (vga-sequencer-register i))) + (cons :crtc + (loop for i from 0 below 25 + collect (vga-crt-controller-register i))) + (cons :graphics + (loop for i from 0 below 9 + collect (vga-graphics-register i))) + (cons :attribute + (loop for i from 0 below 21 + collect (vga-attribute-register i)))) + ;; lock 16-color palette and unblank display + (io-port VGA-INSTAT-READ :unsigned-byte8) + (setf (io-port VGA-AC-INDEX :unsigned-byte8) #x20))) + +(defun (setf vga-state) (state &optional unsafe-p) + "Initialize the state of the VGA register set." + (let ((old-state (if unsafe-p nil (vga-state)))) + (flet ((vga-reset (&optional c) + (declare (ignore c)) + (when old-state + (warn "Something bad happened, resetting VGA state..") + (setf (vga-state t) old-state + old-state nil))) + (assert-register-set (state register-set) + (let ((set (assoc register-set state))) + (assert set () "VGA state is missing ~A." register-set) + (cdr set)))) + (unwind-protect + (handler-bind ((serious-condition #'vga-reset)) + ;; write MISCELLANEOUS reg + (setf (vga-port +vga-misc-write+) + (assert-register-set state :misc)) + ;; write SEQUENCER regs + (loop for x in (assert-register-set state :sequencer) + as i upfrom 0 + do (setf (vga-sequencer-register i) x)) + (loop + ;; unlock CRTC registers + initially (setf (vga-crt-controller-register 3) + (logior #x80 (vga-crt-controller-register 3))) + (setf (vga-crt-controller-register #x11) + (logand #x7f (vga-crt-controller-register #x11))) + for x in (assert-register-set state :crtc) + as i upfrom 0 + do (setf (vga-crt-controller-register i) + (case i + ;; make sure they remain unlocked + (#x03 (logior #x80 x)) + (#x11 (logand #x7f x)) + (t x)))) + ;; write GRAPHICS CONTROLLER regs + (loop for x in (assert-register-set state :graphics) + as i upfrom 0 + do (setf (vga-graphics-register i) x)) + ;; write ATTRIBUTE CONTROLLER regs + (loop for x in (assert-register-set state :attribute) + as i upfrom 0 + do (setf (vga-attribute-register i) x)) + ;; lock 16-color palette and unblank display + (io-port VGA-INSTAT-READ :unsigned-byte8) + (setf (io-port VGA-AC-INDEX :unsigned-byte8) #x20) + (setf old-state nil)) + (vga-reset)))) + state) + +(defun set-plane (p) + (check-type p (integer 0 3)) + (let* ((p (logand p 3)) + (pmask (ash 1 p))) + ;; set read plane + (setf (io-port VGA-GC-INDEX :unsigned-byte8) 4) + (setf (io-port VGA-GC-DATA :unsigned-byte8) p) + ;; set write plane + (setf (io-port VGA-SEQ-INDEX :unsigned-byte8) 2) + (setf (io-port VGA-SEQ-DATA :unsigned-byte8) pmask)) + (values)) + +(defun vmemwr (dst-off src start end) + (loop for i from start below end as dst upfrom dst-off + do (setf (memref-int (vga-memory-map) 0 dst :unsigned-byte8 t) + (aref src i))) + (values)) + +(defun write-font (buf font-height) + (let* ((seq2 + (progn + ;; set_plane() modifies GC 4 and SEQ 2, so save them as well + (setf (io-port VGA-SEQ-INDEX :unsigned-byte8) 2) + (io-port VGA-SEQ-DATA :unsigned-byte8))) + (seq4 + (progn + (setf (io-port VGA-SEQ-INDEX :unsigned-byte8) 4) + (io-port VGA-SEQ-DATA :unsigned-byte8))) + (gc4 + (progn + ;; turn off even-odd addressing (set flat addressing) + ;; assume: chain-4 addressing already off + (setf (io-port VGA-SEQ-DATA :unsigned-byte8) + (logior #x04 seq4)) + (setf (io-port VGA-GC-INDEX :unsigned-byte8) 4) + (io-port VGA-GC-DATA :unsigned-byte8))) + (gc5 + (progn + (setf (io-port VGA-GC-INDEX :unsigned-byte8) 5) + (io-port VGA-GC-DATA :unsigned-byte8))) + (gc6 + (progn + ;; turn off even-odd addressing + (setf (io-port VGA-GC-DATA :unsigned-byte8) + (logand gc5 (logxor #x10 #xff))) + (setf (io-port VGA-GC-INDEX :unsigned-byte8) 6) + (io-port VGA-GC-DATA :unsigned-byte8)))) + ;; turn off even-odd addressing + (setf (io-port VGA-GC-DATA :unsigned-byte8) + (logand gc6 (logxor #xff #x02))) + ;; write font to plane P4 + (set-plane 2) ; set_plane(2) + ;; write font 0 + (dotimes (i 256) + (vmemwr (* i 32) buf (* i font-height) (* (1+ i) font-height))) + + ;; restore registers + (setf (io-port VGA-SEQ-INDEX :unsigned-byte8) 2) + (setf (io-port VGA-SEQ-DATA :unsigned-byte8) seq2) + (setf (io-port VGA-SEQ-INDEX :unsigned-byte8) 4) + (setf (io-port VGA-SEQ-DATA :unsigned-byte8) seq4) + (setf (io-port VGA-GC-INDEX :unsigned-byte8) 4) + (setf (io-port VGA-GC-DATA :unsigned-byte8) gc4) + (setf (io-port VGA-GC-INDEX :unsigned-byte8) 5) + (setf (io-port VGA-GC-DATA :unsigned-byte8) gc5) + (setf (io-port VGA-GC-INDEX :unsigned-byte8) 6) + (setf (io-port VGA-GC-DATA :unsigned-byte8) gc6)) + (values)) + + +(defconstant +vga-font-8x8+ + #{#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x7E #x81 #xA5 #x81 #xBD #x99 #x81 #x7E + #x7E #xFF #xDB #xFF #xC3 #xE7 #xFF #x7E + #x6C #xFE #xFE #xFE #x7C #x38 #x10 #x00 + #x10 #x38 #x7C #xFE #x7C #x38 #x10 #x00 + #x38 #x7C #x38 #xFE #xFE #x92 #x10 #x7C + #x00 #x10 #x38 #x7C #xFE #x7C #x38 #x7C + #x00 #x00 #x18 #x3C #x3C #x18 #x00 #x00 + #xFF #xFF #xE7 #xC3 #xC3 #xE7 #xFF #xFF + #x00 #x3C #x66 #x42 #x42 #x66 #x3C #x00 + #xFF #xC3 #x99 #xBD #xBD #x99 #xC3 #xFF + #x0F #x07 #x0F #x7D #xCC #xCC #xCC #x78 + #x3C #x66 #x66 #x66 #x3C #x18 #x7E #x18 + #x3F #x33 #x3F #x30 #x30 #x70 #xF0 #xE0 + #x7F #x63 #x7F #x63 #x63 #x67 #xE6 #xC0 + #x99 #x5A #x3C #xE7 #xE7 #x3C #x5A #x99 + #x80 #xE0 #xF8 #xFE #xF8 #xE0 #x80 #x00 + #x02 #x0E #x3E #xFE #x3E #x0E #x02 #x00 + #x18 #x3C #x7E #x18 #x18 #x7E #x3C #x18 + #x66 #x66 #x66 #x66 #x66 #x00 #x66 #x00 + #x7F #xDB #xDB #x7B #x1B #x1B #x1B #x00 + #x3E #x63 #x38 #x6C #x6C #x38 #x86 #xFC + #x00 #x00 #x00 #x00 #x7E #x7E #x7E #x00 + #x18 #x3C #x7E #x18 #x7E #x3C #x18 #xFF + #x18 #x3C #x7E #x18 #x18 #x18 #x18 #x00 + #x18 #x18 #x18 #x18 #x7E #x3C #x18 #x00 + #x00 #x18 #x0C #xFE #x0C #x18 #x00 #x00 + #x00 #x30 #x60 #xFE #x60 #x30 #x00 #x00 + #x00 #x00 #xC0 #xC0 #xC0 #xFE #x00 #x00 + #x00 #x24 #x66 #xFF #x66 #x24 #x00 #x00 + #x00 #x18 #x3C #x7E #xFF #xFF #x00 #x00 + #x00 #xFF #xFF #x7E #x3C #x18 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x18 #x3C #x3C #x18 #x18 #x00 #x18 #x00 + #x6C #x6C #x6C #x00 #x00 #x00 #x00 #x00 + #x6C #x6C #xFE #x6C #xFE #x6C #x6C #x00 + #x18 #x7E #xC0 #x7C #x06 #xFC #x18 #x00 + #x00 #xC6 #xCC #x18 #x30 #x66 #xC6 #x00 + #x38 #x6C #x38 #x76 #xDC #xCC #x76 #x00 + #x30 #x30 #x60 #x00 #x00 #x00 #x00 #x00 + #x18 #x30 #x60 #x60 #x60 #x30 #x18 #x00 + #x60 #x30 #x18 #x18 #x18 #x30 #x60 #x00 + #x00 #x66 #x3C #xFF #x3C #x66 #x00 #x00 + #x00 #x18 #x18 #x7E #x18 #x18 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x18 #x18 #x30 + #x00 #x00 #x00 #x7E #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x18 #x18 #x00 + #x06 #x0C #x18 #x30 #x60 #xC0 #x80 #x00 + #x7C #xCE #xDE #xF6 #xE6 #xC6 #x7C #x00 + #x30 #x70 #x30 #x30 #x30 #x30 #xFC #x00 + #x78 #xCC #x0C #x38 #x60 #xCC #xFC #x00 + #x78 #xCC #x0C #x38 #x0C #xCC #x78 #x00 + #x1C #x3C #x6C #xCC #xFE #x0C #x1E #x00 + #xFC #xC0 #xF8 #x0C #x0C #xCC #x78 #x00 + #x38 #x60 #xC0 #xF8 #xCC #xCC #x78 #x00 + #xFC #xCC #x0C #x18 #x30 #x30 #x30 #x00 + #x78 #xCC #xCC #x78 #xCC #xCC #x78 #x00 + #x78 #xCC #xCC #x7C #x0C #x18 #x70 #x00 + #x00 #x18 #x18 #x00 #x00 #x18 #x18 #x00 + #x00 #x18 #x18 #x00 #x00 #x18 #x18 #x30 + #x18 #x30 #x60 #xC0 #x60 #x30 #x18 #x00 + #x00 #x00 #x7E #x00 #x7E #x00 #x00 #x00 + #x60 #x30 #x18 #x0C #x18 #x30 #x60 #x00 + #x3C #x66 #x0C #x18 #x18 #x00 #x18 #x00 + #x7C #xC6 #xDE #xDE #xDC #xC0 #x7C #x00 + #x30 #x78 #xCC #xCC #xFC #xCC #xCC #x00 + #xFC #x66 #x66 #x7C #x66 #x66 #xFC #x00 + #x3C #x66 #xC0 #xC0 #xC0 #x66 #x3C #x00 + #xF8 #x6C #x66 #x66 #x66 #x6C #xF8 #x00 + #xFE #x62 #x68 #x78 #x68 #x62 #xFE #x00 + #xFE #x62 #x68 #x78 #x68 #x60 #xF0 #x00 + #x3C #x66 #xC0 #xC0 #xCE #x66 #x3A #x00 + #xCC #xCC #xCC #xFC #xCC #xCC #xCC #x00 + #x78 #x30 #x30 #x30 #x30 #x30 #x78 #x00 + #x1E #x0C #x0C #x0C #xCC #xCC #x78 #x00 + #xE6 #x66 #x6C #x78 #x6C #x66 #xE6 #x00 + #xF0 #x60 #x60 #x60 #x62 #x66 #xFE #x00 + #xC6 #xEE #xFE #xFE #xD6 #xC6 #xC6 #x00 + #xC6 #xE6 #xF6 #xDE #xCE #xC6 #xC6 #x00 + #x38 #x6C #xC6 #xC6 #xC6 #x6C #x38 #x00 + #xFC #x66 #x66 #x7C #x60 #x60 #xF0 #x00 + #x7C #xC6 #xC6 #xC6 #xD6 #x7C #x0E #x00 + #xFC #x66 #x66 #x7C #x6C #x66 #xE6 #x00 + #x7C #xC6 #xE0 #x78 #x0E #xC6 #x7C #x00 + #xFC #xB4 #x30 #x30 #x30 #x30 #x78 #x00 + #xCC #xCC #xCC #xCC #xCC #xCC #xFC #x00 + #xCC #xCC #xCC #xCC #xCC #x78 #x30 #x00 + #xC6 #xC6 #xC6 #xC6 #xD6 #xFE #x6C #x00 + #xC6 #xC6 #x6C #x38 #x6C #xC6 #xC6 #x00 + #xCC #xCC #xCC #x78 #x30 #x30 #x78 #x00 + #xFE #xC6 #x8C #x18 #x32 #x66 #xFE #x00 + #x78 #x60 #x60 #x60 #x60 #x60 #x78 #x00 + #xC0 #x60 #x30 #x18 #x0C #x06 #x02 #x00 + #x78 #x18 #x18 #x18 #x18 #x18 #x78 #x00 + #x10 #x38 #x6C #xC6 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xFF + #x30 #x30 #x18 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x78 #x0C #x7C #xCC #x76 #x00 + #xE0 #x60 #x60 #x7C #x66 #x66 #xDC #x00 + #x00 #x00 #x78 #xCC #xC0 #xCC #x78 #x00 + #x1C #x0C #x0C #x7C #xCC #xCC #x76 #x00 + #x00 #x00 #x78 #xCC #xFC #xC0 #x78 #x00 + #x38 #x6C #x64 #xF0 #x60 #x60 #xF0 #x00 + #x00 #x00 #x76 #xCC #xCC #x7C #x0C #xF8 + #xE0 #x60 #x6C #x76 #x66 #x66 #xE6 #x00 + #x30 #x00 #x70 #x30 #x30 #x30 #x78 #x00 + #x0C #x00 #x1C #x0C #x0C #xCC #xCC #x78 + #xE0 #x60 #x66 #x6C #x78 #x6C #xE6 #x00 + #x70 #x30 #x30 #x30 #x30 #x30 #x78 #x00 + #x00 #x00 #xCC #xFE #xFE #xD6 #xD6 #x00 + #x00 #x00 #xB8 #xCC #xCC #xCC #xCC #x00 + #x00 #x00 #x78 #xCC #xCC #xCC #x78 #x00 + #x00 #x00 #xDC #x66 #x66 #x7C #x60 #xF0 + #x00 #x00 #x76 #xCC #xCC #x7C #x0C #x1E + #x00 #x00 #xDC #x76 #x62 #x60 #xF0 #x00 + #x00 #x00 #x7C #xC0 #x70 #x1C #xF8 #x00 + #x10 #x30 #xFC #x30 #x30 #x34 #x18 #x00 + #x00 #x00 #xCC #xCC #xCC #xCC #x76 #x00 + #x00 #x00 #xCC #xCC #xCC #x78 #x30 #x00 + #x00 #x00 #xC6 #xC6 #xD6 #xFE #x6C #x00 + #x00 #x00 #xC6 #x6C #x38 #x6C #xC6 #x00 + #x00 #x00 #xCC #xCC #xCC #x7C #x0C #xF8 + #x00 #x00 #xFC #x98 #x30 #x64 #xFC #x00 + #x1C #x30 #x30 #xE0 #x30 #x30 #x1C #x00 + #x18 #x18 #x18 #x00 #x18 #x18 #x18 #x00 + #xE0 #x30 #x30 #x1C #x30 #x30 #xE0 #x00 + #x76 #xDC #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x10 #x38 #x6C #xC6 #xC6 #xFE #x00 + #x7C #xC6 #xC0 #xC6 #x7C #x0C #x06 #x7C + #x00 #xCC #x00 #xCC #xCC #xCC #x76 #x00 + #x1C #x00 #x78 #xCC #xFC #xC0 #x78 #x00 + #x7E #x81 #x3C #x06 #x3E #x66 #x3B #x00 + #xCC #x00 #x78 #x0C #x7C #xCC #x76 #x00 + #xE0 #x00 #x78 #x0C #x7C #xCC #x76 #x00 + #x30 #x30 #x78 #x0C #x7C #xCC #x76 #x00 + #x00 #x00 #x7C #xC6 #xC0 #x78 #x0C #x38 + #x7E #x81 #x3C #x66 #x7E #x60 #x3C #x00 + #xCC #x00 #x78 #xCC #xFC #xC0 #x78 #x00 + #xE0 #x00 #x78 #xCC #xFC #xC0 #x78 #x00 + #xCC #x00 #x70 #x30 #x30 #x30 #x78 #x00 + #x7C #x82 #x38 #x18 #x18 #x18 #x3C #x00 + #xE0 #x00 #x70 #x30 #x30 #x30 #x78 #x00 + #xC6 #x10 #x7C #xC6 #xFE #xC6 #xC6 #x00 + #x30 #x30 #x00 #x78 #xCC #xFC #xCC #x00 + #x1C #x00 #xFC #x60 #x78 #x60 #xFC #x00 + #x00 #x00 #x7F #x0C #x7F #xCC #x7F #x00 + #x3E #x6C #xCC #xFE #xCC #xCC #xCE #x00 + #x78 #x84 #x00 #x78 #xCC #xCC #x78 #x00 + #x00 #xCC #x00 #x78 #xCC #xCC #x78 #x00 + #x00 #xE0 #x00 #x78 #xCC #xCC #x78 #x00 + #x78 #x84 #x00 #xCC #xCC #xCC #x76 #x00 + #x00 #xE0 #x00 #xCC #xCC #xCC #x76 #x00 + #x00 #xCC #x00 #xCC #xCC #x7C #x0C #xF8 + #xC3 #x18 #x3C #x66 #x66 #x3C #x18 #x00 + #xCC #x00 #xCC #xCC #xCC #xCC #x78 #x00 + #x18 #x18 #x7E #xC0 #xC0 #x7E #x18 #x18 + #x38 #x6C #x64 #xF0 #x60 #xE6 #xFC #x00 + #xCC #xCC #x78 #x30 #xFC #x30 #xFC #x30 + #xF8 #xCC #xCC #xFA #xC6 #xCF #xC6 #xC3 + #x0E #x1B #x18 #x3C #x18 #x18 #xD8 #x70 + #x1C #x00 #x78 #x0C #x7C #xCC #x76 #x00 + #x38 #x00 #x70 #x30 #x30 #x30 #x78 #x00 + #x00 #x1C #x00 #x78 #xCC #xCC #x78 #x00 + #x00 #x1C #x00 #xCC #xCC #xCC #x76 #x00 + #x00 #xF8 #x00 #xB8 #xCC #xCC #xCC #x00 + #xFC #x00 #xCC #xEC #xFC #xDC #xCC #x00 + #x3C #x6C #x6C #x3E #x00 #x7E #x00 #x00 + #x38 #x6C #x6C #x38 #x00 #x7C #x00 #x00 + #x18 #x00 #x18 #x18 #x30 #x66 #x3C #x00 + #x00 #x00 #x00 #xFC #xC0 #xC0 #x00 #x00 + #x00 #x00 #x00 #xFC #x0C #x0C #x00 #x00 + #xC6 #xCC #xD8 #x36 #x6B #xC2 #x84 #x0F + #xC3 #xC6 #xCC #xDB #x37 #x6D #xCF #x03 + #x18 #x00 #x18 #x18 #x3C #x3C #x18 #x00 + #x00 #x33 #x66 #xCC #x66 #x33 #x00 #x00 + #x00 #xCC #x66 #x33 #x66 #xCC #x00 #x00 + #x22 #x88 #x22 #x88 #x22 #x88 #x22 #x88 + #x55 #xAA #x55 #xAA #x55 #xAA #x55 #xAA + #xDB #xF6 #xDB #x6F #xDB #x7E #xD7 #xED + #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 + #x18 #x18 #x18 #x18 #xF8 #x18 #x18 #x18 + #x18 #x18 #xF8 #x18 #xF8 #x18 #x18 #x18 + #x36 #x36 #x36 #x36 #xF6 #x36 #x36 #x36 + #x00 #x00 #x00 #x00 #xFE #x36 #x36 #x36 + #x00 #x00 #xF8 #x18 #xF8 #x18 #x18 #x18 + #x36 #x36 #xF6 #x06 #xF6 #x36 #x36 #x36 + #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 + #x00 #x00 #xFE #x06 #xF6 #x36 #x36 #x36 + #x36 #x36 #xF6 #x06 #xFE #x00 #x00 #x00 + #x36 #x36 #x36 #x36 #xFE #x00 #x00 #x00 + #x18 #x18 #xF8 #x18 #xF8 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #xF8 #x18 #x18 #x18 + #x18 #x18 #x18 #x18 #x1F #x00 #x00 #x00 + #x18 #x18 #x18 #x18 #xFF #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #xFF #x18 #x18 #x18 + #x18 #x18 #x18 #x18 #x1F #x18 #x18 #x18 + #x00 #x00 #x00 #x00 #xFF #x00 #x00 #x00 + #x18 #x18 #x18 #x18 #xFF #x18 #x18 #x18 + #x18 #x18 #x1F #x18 #x1F #x18 #x18 #x18 + #x36 #x36 #x36 #x36 #x37 #x36 #x36 #x36 + #x36 #x36 #x37 #x30 #x3F #x00 #x00 #x00 + #x00 #x00 #x3F #x30 #x37 #x36 #x36 #x36 + #x36 #x36 #xF7 #x00 #xFF #x00 #x00 #x00 + #x00 #x00 #xFF #x00 #xF7 #x36 #x36 #x36 + #x36 #x36 #x37 #x30 #x37 #x36 #x36 #x36 + #x00 #x00 #xFF #x00 #xFF #x00 #x00 #x00 + #x36 #x36 #xF7 #x00 #xF7 #x36 #x36 #x36 + #x18 #x18 #xFF #x00 #xFF #x00 #x00 #x00 + #x36 #x36 #x36 #x36 #xFF #x00 #x00 #x00 + #x00 #x00 #xFF #x00 #xFF #x18 #x18 #x18 + #x00 #x00 #x00 #x00 #xFF #x36 #x36 #x36 + #x36 #x36 #x36 #x36 #x3F #x00 #x00 #x00 + #x18 #x18 #x1F #x18 #x1F #x00 #x00 #x00 + #x00 #x00 #x1F #x18 #x1F #x18 #x18 #x18 + #x00 #x00 #x00 #x00 #x3F #x36 #x36 #x36 + #x36 #x36 #x36 #x36 #xFF #x36 #x36 #x36 + #x18 #x18 #xFF #x18 #xFF #x18 #x18 #x18 + #x18 #x18 #x18 #x18 #xF8 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x1F #x18 #x18 #x18 + #xFF #xFF #xFF #xFF #xFF #xFF #xFF #xFF + #x00 #x00 #x00 #x00 #xFF #xFF #xFF #xFF + #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 + #x0F #x0F #x0F #x0F #x0F #x0F #x0F #x0F + #xFF #xFF #xFF #xFF #x00 #x00 #x00 #x00 + #x00 #x00 #x76 #xDC #xC8 #xDC #x76 #x00 + #x00 #x78 #xCC #xF8 #xCC #xF8 #xC0 #xC0 + #x00 #xFC #xCC #xC0 #xC0 #xC0 #xC0 #x00 + #x00 #x00 #xFE #x6C #x6C #x6C #x6C #x00 + #xFC #xCC #x60 #x30 #x60 #xCC #xFC #x00 + #x00 #x00 #x7E #xD8 #xD8 #xD8 #x70 #x00 + #x00 #x66 #x66 #x66 #x66 #x7C #x60 #xC0 + #x00 #x76 #xDC #x18 #x18 #x18 #x18 #x00 + #xFC #x30 #x78 #xCC #xCC #x78 #x30 #xFC + #x38 #x6C #xC6 #xFE #xC6 #x6C #x38 #x00 + #x38 #x6C #xC6 #xC6 #x6C #x6C #xEE #x00 + #x1C #x30 #x18 #x7C #xCC #xCC #x78 #x00 + #x00 #x00 #x7E #xDB #xDB #x7E #x00 #x00 + #x06 #x0C #x7E #xDB #xDB #x7E #x60 #xC0 + #x38 #x60 #xC0 #xF8 #xC0 #x60 #x38 #x00 + #x78 #xCC #xCC #xCC #xCC #xCC #xCC #x00 + #x00 #x7E #x00 #x7E #x00 #x7E #x00 #x00 + #x18 #x18 #x7E #x18 #x18 #x00 #x7E #x00 + #x60 #x30 #x18 #x30 #x60 #x00 #xFC #x00 + #x18 #x30 #x60 #x30 #x18 #x00 #xFC #x00 + #x0E #x1B #x1B #x18 #x18 #x18 #x18 #x18 + #x18 #x18 #x18 #x18 #x18 #xD8 #xD8 #x70 + #x18 #x18 #x00 #x7E #x00 #x18 #x18 #x00 + #x00 #x76 #xDC #x00 #x76 #xDC #x00 #x00 + #x38 #x6C #x6C #x38 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x18 #x18 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x18 #x00 #x00 #x00 + #x0F #x0C #x0C #x0C #xEC #x6C #x3C #x1C + #x58 #x6C #x6C #x6C #x6C #x00 #x00 #x00 + #x70 #x98 #x30 #x60 #xF8 #x00 #x00 #x00 + #x00 #x00 #x3C #x3C #x3C #x3C #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 }) + +(defconstant +vga-font-8x16+ + #{#x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x7E #x81 #xA5 #x81 #x81 #xBD #x99 #x81 #x81 #x7E #x00 #x00 #x00 #x00 + #x00 #x00 #x7E #xFF #xDB #xFF #xFF #xC3 #xE7 #xFF #xFF #x7E #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x6C #xFE #xFE #xFE #xFE #x7C #x38 #x10 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x10 #x38 #x7C #xFE #x7C #x38 #x10 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x18 #x3C #x3C #xE7 #xE7 #xE7 #x99 #x18 #x3C #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x18 #x3C #x7E #xFF #xFF #x7E #x18 #x18 #x3C #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #x18 #x3C #x3C #x18 #x00 #x00 #x00 #x00 #x00 #x00 + #xFF #xFF #xFF #xFF #xFF #xFF #xE7 #xC3 #xC3 #xE7 #xFF #xFF #xFF #xFF #xFF #xFF + #x00 #x00 #x00 #x00 #x00 #x3C #x66 #x42 #x42 #x66 #x3C #x00 #x00 #x00 #x00 #x00 + #xFF #xFF #xFF #xFF #xFF #xC3 #x99 #xBD #xBD #x99 #xC3 #xFF #xFF #xFF #xFF #xFF + #x00 #x00 #x1E #x0E #x1A #x32 #x78 #xCC #xCC #xCC #xCC #x78 #x00 #x00 #x00 #x00 + #x00 #x00 #x3C #x66 #x66 #x66 #x66 #x3C #x18 #x7E #x18 #x18 #x00 #x00 #x00 #x00 + #x00 #x00 #x3F #x33 #x3F #x30 #x30 #x30 #x30 #x70 #xF0 #xE0 #x00 #x00 #x00 #x00 + #x00 #x00 #x7F #x63 #x7F #x63 #x63 #x63 #x63 #x67 #xE7 #xE6 #xC0 #x00 #x00 #x00 + #x00 #x00 #x00 #x18 #x18 #xDB #x3C #xE7 #x3C #xDB #x18 #x18 #x00 #x00 #x00 #x00 + #x00 #x80 #xC0 #xE0 #xF0 #xF8 #xFE #xF8 #xF0 #xE0 #xC0 #x80 #x00 #x00 #x00 #x00 + #x00 #x02 #x06 #x0E #x1E #x3E #xFE #x3E #x1E #x0E #x06 #x02 #x00 #x00 #x00 #x00 + #x00 #x00 #x18 #x3C #x7E #x18 #x18 #x18 #x18 #x7E #x3C #x18 #x00 #x00 #x00 #x00 + #x00 #x00 #x66 #x66 #x66 #x66 #x66 #x66 #x66 #x00 #x66 #x66 #x00 #x00 #x00 #x00 + #x00 #x00 #x7F #xDB #xDB #xDB #x7B #x1B #x1B #x1B #x1B #x1B #x00 #x00 #x00 #x00 + #x00 #x7C #xC6 #x60 #x38 #x6C #xC6 #xC6 #x6C #x38 #x0C #xC6 #x7C #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xFE #xFE #xFE #xFE #x00 #x00 #x00 #x00 + #x00 #x00 #x18 #x3C #x7E #x18 #x18 #x18 #x18 #x7E #x3C #x18 #x7E #x00 #x00 #x00 + #x00 #x00 #x18 #x3C #x7E #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x00 #x00 #x00 #x00 + #x00 #x00 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x7E #x3C #x18 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x18 #x0C #xFE #x0C #x18 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x30 #x60 #xFE #x60 #x30 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #xC0 #xC0 #xC0 #xC0 #xFE #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x28 #x6C #xFE #x6C #x28 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x10 #x38 #x38 #x7C #x7C #xFE #xFE #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #xFE #xFE #x7C #x7C #x38 #x38 #x10 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x18 #x3C #x3C #x3C #x18 #x18 #x18 #x00 #x18 #x18 #x00 #x00 #x00 #x00 + #x00 #x66 #x66 #x66 #x24 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x6C #x6C #xFE #x6C #x6C #x6C #xFE #x6C #x6C #x00 #x00 #x00 #x00 + #x18 #x18 #x7C #xC6 #xC2 #xC0 #x7C #x06 #x86 #xC6 #x7C #x18 #x18 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #xC2 #xC6 #x0C #x18 #x30 #x60 #xC6 #x86 #x00 #x00 #x00 #x00 + #x00 #x00 #x38 #x6C #x6C #x38 #x76 #xDC #xCC #xCC #xCC #x76 #x00 #x00 #x00 #x00 + #x00 #x30 #x30 #x30 #x60 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x0C #x18 #x30 #x30 #x30 #x30 #x30 #x30 #x18 #x0C #x00 #x00 #x00 #x00 + #x00 #x00 #x30 #x18 #x0C #x0C #x0C #x0C #x0C #x0C #x18 #x30 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x66 #x3C #xFF #x3C #x66 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x18 #x18 #x7E #x18 #x18 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x18 #x18 #x18 #x30 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xFE #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x18 #x18 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x02 #x06 #x0C #x18 #x30 #x60 #xC0 #x80 #x00 #x00 #x00 #x00 + #x00 #x00 #x7C #xC6 #xC6 #xCE #xD6 #xD6 #xE6 #xC6 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x00 #x18 #x38 #x78 #x18 #x18 #x18 #x18 #x18 #x18 #x7E #x00 #x00 #x00 #x00 + #x00 #x00 #x7C #xC6 #x06 #x0C #x18 #x30 #x60 #xC0 #xC6 #xFE #x00 #x00 #x00 #x00 + #x00 #x00 #x7C #xC6 #x06 #x06 #x3C #x06 #x06 #x06 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x00 #x0C #x1C #x3C #x6C #xCC #xFE #x0C #x0C #x0C #x1E #x00 #x00 #x00 #x00 + #x00 #x00 #xFE #xC0 #xC0 #xC0 #xFC #x0E #x06 #x06 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x00 #x38 #x60 #xC0 #xC0 #xFC #xC6 #xC6 #xC6 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x00 #xFE #xC6 #x06 #x06 #x0C #x18 #x30 #x30 #x30 #x30 #x00 #x00 #x00 #x00 + #x00 #x00 #x7C #xC6 #xC6 #xC6 #x7C #xC6 #xC6 #xC6 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x00 #x7C #xC6 #xC6 #xC6 #x7E #x06 #x06 #x06 #x0C #x78 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x18 #x18 #x00 #x00 #x00 #x18 #x18 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x18 #x18 #x00 #x00 #x00 #x18 #x18 #x30 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x06 #x0C #x18 #x30 #x60 #x30 #x18 #x0C #x06 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #xFE #x00 #x00 #xFE #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x60 #x30 #x18 #x0C #x06 #x0C #x18 #x30 #x60 #x00 #x00 #x00 #x00 + #x00 #x00 #x7C #xC6 #xC6 #x0C #x18 #x18 #x18 #x00 #x18 #x18 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x7C #xC6 #xC6 #xDE #xDE #xDE #xDC #xC0 #x7C #x00 #x00 #x00 #x00 + #x00 #x00 #x10 #x38 #x6C #xC6 #xC6 #xFE #xC6 #xC6 #xC6 #xC6 #x00 #x00 #x00 #x00 + #x00 #x00 #xFC #x66 #x66 #x66 #x7C #x66 #x66 #x66 #x66 #xFC #x00 #x00 #x00 #x00 + #x00 #x00 #x3C #x66 #xC2 #xC0 #xC0 #xC0 #xC0 #xC2 #x66 #x3C #x00 #x00 #x00 #x00 + #x00 #x00 #xF8 #x6C #x66 #x66 #x66 #x66 #x66 #x66 #x6C #xF8 #x00 #x00 #x00 #x00 + #x00 #x00 #xFE #x66 #x62 #x68 #x78 #x68 #x60 #x62 #x66 #xFE #x00 #x00 #x00 #x00 + #x00 #x00 #xFE #x66 #x62 #x68 #x78 #x68 #x60 #x60 #x60 #xF0 #x00 #x00 #x00 #x00 + #x00 #x00 #x3C #x66 #xC2 #xC0 #xC0 #xDE #xC6 #xC6 #x66 #x3A #x00 #x00 #x00 #x00 + #x00 #x00 #xC6 #xC6 #xC6 #xC6 #xFE #xC6 #xC6 #xC6 #xC6 #xC6 #x00 #x00 #x00 #x00 + #x00 #x00 #x3C #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x3C #x00 #x00 #x00 #x00 + #x00 #x00 #x1E #x0C #x0C #x0C #x0C #x0C #xCC #xCC #xCC #x78 #x00 #x00 #x00 #x00 + #x00 #x00 #xE6 #x66 #x6C #x6C #x78 #x78 #x6C #x66 #x66 #xE6 #x00 #x00 #x00 #x00 + #x00 #x00 #xF0 #x60 #x60 #x60 #x60 #x60 #x60 #x62 #x66 #xFE #x00 #x00 #x00 #x00 + #x00 #x00 #xC6 #xEE #xFE #xFE #xD6 #xC6 #xC6 #xC6 #xC6 #xC6 #x00 #x00 #x00 #x00 + #x00 #x00 #xC6 #xE6 #xF6 #xFE #xDE #xCE #xC6 #xC6 #xC6 #xC6 #x00 #x00 #x00 #x00 + #x00 #x00 #x38 #x6C #xC6 #xC6 #xC6 #xC6 #xC6 #xC6 #x6C #x38 #x00 #x00 #x00 #x00 + #x00 #x00 #xFC #x66 #x66 #x66 #x7C #x60 #x60 #x60 #x60 #xF0 #x00 #x00 #x00 #x00 + #x00 #x00 #x7C #xC6 #xC6 #xC6 #xC6 #xC6 #xC6 #xD6 #xDE #x7C #x0C #x0E #x00 #x00 + #x00 #x00 #xFC #x66 #x66 #x66 #x7C #x6C #x66 #x66 #x66 #xE6 #x00 #x00 #x00 #x00 + #x00 #x00 #x7C #xC6 #xC6 #x60 #x38 #x0C #x06 #xC6 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x00 #x7E #x7E #x5A #x18 #x18 #x18 #x18 #x18 #x18 #x3C #x00 #x00 #x00 #x00 + #x00 #x00 #xC6 #xC6 #xC6 #xC6 #xC6 #xC6 #xC6 #xC6 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x00 #xC6 #xC6 #xC6 #xC6 #xC6 #xC6 #xC6 #x6C #x38 #x10 #x00 #x00 #x00 #x00 + #x00 #x00 #xC6 #xC6 #xC6 #xC6 #xC6 #xD6 #xD6 #xFE #x6C #x6C #x00 #x00 #x00 #x00 + #x00 #x00 #xC6 #xC6 #x6C #x6C #x38 #x38 #x6C #x6C #xC6 #xC6 #x00 #x00 #x00 #x00 + #x00 #x00 #x66 #x66 #x66 #x66 #x3C #x18 #x18 #x18 #x18 #x3C #x00 #x00 #x00 #x00 + #x00 #x00 #xFE #xC6 #x86 #x0C #x18 #x30 #x60 #xC2 #xC6 #xFE #x00 #x00 #x00 #x00 + #x00 #x00 #x3C #x30 #x30 #x30 #x30 #x30 #x30 #x30 #x30 #x3C #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x80 #xC0 #xE0 #x70 #x38 #x1C #x0E #x06 #x02 #x00 #x00 #x00 #x00 + #x00 #x00 #x3C #x0C #x0C #x0C #x0C #x0C #x0C #x0C #x0C #x3C #x00 #x00 #x00 #x00 + #x10 #x38 #x6C #xC6 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xFF #x00 #x00 + #x30 #x30 #x18 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x78 #x0C #x7C #xCC #xCC #xCC #x76 #x00 #x00 #x00 #x00 + #x00 #x00 #xE0 #x60 #x60 #x78 #x6C #x66 #x66 #x66 #x66 #xDC #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x7C #xC6 #xC0 #xC0 #xC0 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x00 #x1C #x0C #x0C #x3C #x6C #xCC #xCC #xCC #xCC #x76 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x7C #xC6 #xFE #xC0 #xC0 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x00 #x38 #x6C #x64 #x60 #xF0 #x60 #x60 #x60 #x60 #xF0 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x76 #xCC #xCC #xCC #xCC #xCC #x7C #x0C #xCC #x78 #x00 + #x00 #x00 #xE0 #x60 #x60 #x6C #x76 #x66 #x66 #x66 #x66 #xE6 #x00 #x00 #x00 #x00 + #x00 #x00 #x18 #x18 #x00 #x38 #x18 #x18 #x18 #x18 #x18 #x3C #x00 #x00 #x00 #x00 + #x00 #x00 #x06 #x06 #x00 #x0E #x06 #x06 #x06 #x06 #x06 #x06 #x66 #x66 #x3C #x00 + #x00 #x00 #xE0 #x60 #x60 #x66 #x6C #x78 #x78 #x6C #x66 #xE6 #x00 #x00 #x00 #x00 + #x00 #x00 #x38 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x3C #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #xEC #xFE #xD6 #xD6 #xD6 #xD6 #xD6 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #xDC #x66 #x66 #x66 #x66 #x66 #x66 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x7C #xC6 #xC6 #xC6 #xC6 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #xDC #x66 #x66 #x66 #x66 #x66 #x7C #x60 #x60 #xF0 #x00 + #x00 #x00 #x00 #x00 #x00 #x76 #xCC #xCC #xCC #xCC #xCC #x7C #x0C #x0C #x1E #x00 + #x00 #x00 #x00 #x00 #x00 #xDC #x76 #x62 #x60 #x60 #x60 #xF0 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x7C #xC6 #x60 #x38 #x0C #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x00 #x10 #x30 #x30 #xFC #x30 #x30 #x30 #x30 #x36 #x1C #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #xCC #xCC #xCC #xCC #xCC #xCC #x76 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x66 #x66 #x66 #x66 #x66 #x3C #x18 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #xC6 #xC6 #xC6 #xD6 #xD6 #xFE #x6C #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #xC6 #x6C #x38 #x38 #x38 #x6C #xC6 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #xC6 #xC6 #xC6 #xC6 #xC6 #xC6 #x7E #x06 #x0C #xF8 #x00 + #x00 #x00 #x00 #x00 #x00 #xFE #xCC #x18 #x30 #x60 #xC6 #xFE #x00 #x00 #x00 #x00 + #x00 #x00 #x0E #x18 #x18 #x18 #x70 #x18 #x18 #x18 #x18 #x0E #x00 #x00 #x00 #x00 + #x00 #x00 #x18 #x18 #x18 #x18 #x00 #x18 #x18 #x18 #x18 #x18 #x00 #x00 #x00 #x00 + #x00 #x00 #x70 #x18 #x18 #x18 #x0E #x18 #x18 #x18 #x18 #x70 #x00 #x00 #x00 #x00 + #x00 #x00 #x76 #xDC #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x10 #x38 #x6C #xC6 #xC6 #xC6 #xFE #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x3C #x66 #xC2 #xC0 #xC0 #xC0 #xC2 #x66 #x3C #x0C #x06 #x7C #x00 #x00 + #x00 #x00 #xCC #xCC #x00 #xCC #xCC #xCC #xCC #xCC #xCC #x76 #x00 #x00 #x00 #x00 + #x00 #x0C #x18 #x30 #x00 #x7C #xC6 #xFE #xC0 #xC0 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x10 #x38 #x6C #x00 #x78 #x0C #x7C #xCC #xCC #xCC #x76 #x00 #x00 #x00 #x00 + #x00 #x00 #xCC #xCC #x00 #x78 #x0C #x7C #xCC #xCC #xCC #x76 #x00 #x00 #x00 #x00 + #x00 #x60 #x30 #x18 #x00 #x78 #x0C #x7C #xCC #xCC #xCC #x76 #x00 #x00 #x00 #x00 + #x00 #x38 #x6C #x38 #x00 #x78 #x0C #x7C #xCC #xCC #xCC #x76 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x3C #x66 #x60 #x60 #x66 #x3C #x0C #x06 #x3C #x00 #x00 #x00 + #x00 #x10 #x38 #x6C #x00 #x7C #xC6 #xFE #xC0 #xC0 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x00 #xC6 #xC6 #x00 #x7C #xC6 #xFE #xC0 #xC0 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x60 #x30 #x18 #x00 #x7C #xC6 #xFE #xC0 #xC0 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x00 #x66 #x66 #x00 #x38 #x18 #x18 #x18 #x18 #x18 #x3C #x00 #x00 #x00 #x00 + #x00 #x18 #x3C #x66 #x00 #x38 #x18 #x18 #x18 #x18 #x18 #x3C #x00 #x00 #x00 #x00 + #x00 #x60 #x30 #x18 #x00 #x38 #x18 #x18 #x18 #x18 #x18 #x3C #x00 #x00 #x00 #x00 + #x00 #xC6 #xC6 #x10 #x38 #x6C #xC6 #xC6 #xFE #xC6 #xC6 #xC6 #x00 #x00 #x00 #x00 + #x38 #x6C #x38 #x00 #x38 #x6C #xC6 #xC6 #xFE #xC6 #xC6 #xC6 #x00 #x00 #x00 #x00 + #x18 #x30 #x60 #x00 #xFE #x66 #x60 #x7C #x60 #x60 #x66 #xFE #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #xCC #x76 #x36 #x7E #xD8 #xD8 #x6E #x00 #x00 #x00 #x00 + #x00 #x00 #x3E #x6C #xCC #xCC #xFE #xCC #xCC #xCC #xCC #xCE #x00 #x00 #x00 #x00 + #x00 #x10 #x38 #x6C #x00 #x7C #xC6 #xC6 #xC6 #xC6 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x00 #xC6 #xC6 #x00 #x7C #xC6 #xC6 #xC6 #xC6 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x60 #x30 #x18 #x00 #x7C #xC6 #xC6 #xC6 #xC6 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x30 #x78 #xCC #x00 #xCC #xCC #xCC #xCC #xCC #xCC #x76 #x00 #x00 #x00 #x00 + #x00 #x60 #x30 #x18 #x00 #xCC #xCC #xCC #xCC #xCC #xCC #x76 #x00 #x00 #x00 #x00 + #x00 #x00 #xC6 #xC6 #x00 #xC6 #xC6 #xC6 #xC6 #xC6 #xC6 #x7E #x06 #x0C #x78 #x00 + #x00 #xC6 #xC6 #x00 #x38 #x6C #xC6 #xC6 #xC6 #xC6 #x6C #x38 #x00 #x00 #x00 #x00 + #x00 #xC6 #xC6 #x00 #xC6 #xC6 #xC6 #xC6 #xC6 #xC6 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x18 #x18 #x3C #x66 #x60 #x60 #x60 #x66 #x3C #x18 #x18 #x00 #x00 #x00 #x00 + #x00 #x38 #x6C #x64 #x60 #xF0 #x60 #x60 #x60 #x60 #xE6 #xFC #x00 #x00 #x00 #x00 + #x00 #x00 #x66 #x66 #x3C #x18 #x7E #x18 #x7E #x18 #x18 #x18 #x00 #x00 #x00 #x00 + #x00 #xF8 #xCC #xCC #xF8 #xC4 #xCC #xDE #xCC #xCC #xCC #xC6 #x00 #x00 #x00 #x00 + #x00 #x0E #x1B #x18 #x18 #x18 #x7E #x18 #x18 #x18 #x18 #x18 #xD8 #x70 #x00 #x00 + #x00 #x18 #x30 #x60 #x00 #x78 #x0C #x7C #xCC #xCC #xCC #x76 #x00 #x00 #x00 #x00 + #x00 #x0C #x18 #x30 #x00 #x38 #x18 #x18 #x18 #x18 #x18 #x3C #x00 #x00 #x00 #x00 + #x00 #x18 #x30 #x60 #x00 #x7C #xC6 #xC6 #xC6 #xC6 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x18 #x30 #x60 #x00 #xCC #xCC #xCC #xCC #xCC #xCC #x76 #x00 #x00 #x00 #x00 + #x00 #x00 #x76 #xDC #x00 #xDC #x66 #x66 #x66 #x66 #x66 #x66 #x00 #x00 #x00 #x00 + #x76 #xDC #x00 #xC6 #xE6 #xF6 #xFE #xDE #xCE #xC6 #xC6 #xC6 #x00 #x00 #x00 #x00 + #x00 #x3C #x6C #x6C #x3E #x00 #x7E #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x38 #x6C #x6C #x38 #x00 #x7C #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x30 #x30 #x00 #x30 #x30 #x60 #xC0 #xC6 #xC6 #x7C #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #xFE #xC0 #xC0 #xC0 #xC0 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #xFE #x06 #x06 #x06 #x06 #x00 #x00 #x00 #x00 #x00 + #x00 #xC0 #xC0 #xC2 #xC6 #xCC #x18 #x30 #x60 #xCE #x93 #x06 #x0C #x1F #x00 #x00 + #x00 #xC0 #xC0 #xC2 #xC6 #xCC #x18 #x30 #x66 #xCE #x9A #x3F #x06 #x0F #x00 #x00 + #x00 #x00 #x18 #x18 #x00 #x18 #x18 #x18 #x3C #x3C #x3C #x18 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x33 #x66 #xCC #x66 #x33 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #xCC #x66 #x33 #x66 #xCC #x00 #x00 #x00 #x00 #x00 #x00 + #x11 #x44 #x11 #x44 #x11 #x44 #x11 #x44 #x11 #x44 #x11 #x44 #x11 #x44 #x11 #x44 + #x55 #xAA #x55 #xAA #x55 #xAA #x55 #xAA #x55 #xAA #x55 #xAA #x55 #xAA #x55 #xAA + #xDD #x77 #xDD #x77 #xDD #x77 #xDD #x77 #xDD #x77 #xDD #x77 #xDD #x77 #xDD #x77 + #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 + #x18 #x18 #x18 #x18 #x18 #x18 #x18 #xF8 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 + #x18 #x18 #x18 #x18 #x18 #xF8 #x18 #xF8 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 + #x36 #x36 #x36 #x36 #x36 #x36 #x36 #xF6 #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xFE #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 + #x00 #x00 #x00 #x00 #x00 #xF8 #x18 #xF8 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 + #x36 #x36 #x36 #x36 #x36 #xF6 #x06 #xF6 #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 + #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 + #x00 #x00 #x00 #x00 #x00 #xFE #x06 #xF6 #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 + #x36 #x36 #x36 #x36 #x36 #xF6 #x06 #xFE #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x36 #x36 #x36 #x36 #x36 #x36 #x36 #xFE #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x18 #x18 #x18 #x18 #x18 #xF8 #x18 #xF8 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xF8 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 + #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x1F #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x18 #x18 #x18 #x18 #x18 #x18 #x18 #xFF #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xFF #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 + #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x1F #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xFF #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x18 #x18 #x18 #x18 #x18 #x18 #x18 #xFF #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 + #x18 #x18 #x18 #x18 #x18 #x1F #x18 #x1F #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 + #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x37 #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 + #x36 #x36 #x36 #x36 #x36 #x37 #x30 #x3F #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x3F #x30 #x37 #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 + #x36 #x36 #x36 #x36 #x36 #xF7 #x00 #xFF #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #xFF #x00 #xF7 #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 + #x36 #x36 #x36 #x36 #x36 #x37 #x30 #x37 #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 + #x00 #x00 #x00 #x00 #x00 #xFF #x00 #xFF #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x36 #x36 #x36 #x36 #x36 #xF7 #x00 #xF7 #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 + #x18 #x18 #x18 #x18 #x18 #xFF #x00 #xFF #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x36 #x36 #x36 #x36 #x36 #x36 #x36 #xFF #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #xFF #x00 #xFF #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xFF #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 + #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x3F #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x18 #x18 #x18 #x18 #x18 #x1F #x18 #x1F #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x1F #x18 #x1F #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x3F #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 + #x36 #x36 #x36 #x36 #x36 #x36 #x36 #xFF #x36 #x36 #x36 #x36 #x36 #x36 #x36 #x36 + #x18 #x18 #x18 #x18 #x18 #xFF #x18 #xFF #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 + #x18 #x18 #x18 #x18 #x18 #x18 #x18 #xF8 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x1F #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 + #xFF #xFF #xFF #xFF #xFF #xFF #xFF #xFF #xFF #xFF #xFF #xFF #xFF #xFF #xFF #xFF + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #xFF #xFF #xFF #xFF #xFF #xFF #xFF #xFF #xFF + #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 #xF0 + #x0F #x0F #x0F #x0F #x0F #x0F #x0F #x0F #x0F #x0F #x0F #x0F #x0F #x0F #x0F #x0F + #xFF #xFF #xFF #xFF #xFF #xFF #xFF #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x76 #xDC #xD8 #xD8 #xD8 #xDC #x76 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #xFC #xC6 #xFC #xC6 #xC6 #xFC #xC0 #xC0 #xC0 #x00 #x00 + #x00 #x00 #xFE #xC6 #xC6 #xC0 #xC0 #xC0 #xC0 #xC0 #xC0 #xC0 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x80 #xFE #x6C #x6C #x6C #x6C #x6C #x6C #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #xFE #xC6 #x60 #x30 #x18 #x30 #x60 #xC6 #xFE #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x7E #xD8 #xD8 #xD8 #xD8 #xD8 #x70 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x66 #x66 #x66 #x66 #x66 #x7C #x60 #x60 #xC0 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x76 #xDC #x18 #x18 #x18 #x18 #x18 #x18 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x7E #x18 #x3C #x66 #x66 #x66 #x3C #x18 #x7E #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x38 #x6C #xC6 #xC6 #xFE #xC6 #xC6 #x6C #x38 #x00 #x00 #x00 #x00 + #x00 #x00 #x38 #x6C #xC6 #xC6 #xC6 #x6C #x6C #x6C #x6C #xEE #x00 #x00 #x00 #x00 + #x00 #x00 #x1E #x30 #x18 #x0C #x3E #x66 #x66 #x66 #x66 #x3C #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x7E #xDB #xDB #xDB #x7E #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x03 #x06 #x7E #xCF #xDB #xF3 #x7E #x60 #xC0 #x00 #x00 #x00 #x00 + #x00 #x00 #x1C #x30 #x60 #x60 #x7C #x60 #x60 #x60 #x30 #x1C #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x7C #xC6 #xC6 #xC6 #xC6 #xC6 #xC6 #xC6 #xC6 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #xFE #x00 #x00 #xFE #x00 #x00 #xFE #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x18 #x18 #x7E #x18 #x18 #x00 #x00 #xFF #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x30 #x18 #x0C #x06 #x0C #x18 #x30 #x00 #x7E #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x0C #x18 #x30 #x60 #x30 #x18 #x0C #x00 #x7E #x00 #x00 #x00 #x00 + #x00 #x00 #x0E #x1B #x1B #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 + #x18 #x18 #x18 #x18 #x18 #x18 #x18 #x18 #xD8 #xD8 #xD8 #x70 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x18 #x18 #x00 #x7E #x00 #x18 #x18 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x76 #xDC #x00 #x76 #xDC #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x38 #x6C #x6C #x38 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x18 #x18 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x18 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x0F #x0C #x0C #x0C #x0C #x0C #xEC #x6C #x6C #x3C #x1C #x00 #x00 #x00 #x00 + #x00 #xD8 #x6C #x6C #x6C #x6C #x6C #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x70 #x98 #x30 #x60 #xC8 #xF8 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x7C #x7C #x7C #x7C #x7C #x7C #x7C #x00 #x00 #x00 #x00 #x00 + #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x00 }) + + From ffjeld at common-lisp.net Fri Apr 23 13:00:12 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 23 Apr 2004 09:00:12 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv1547 Modified Files: los0.lisp Log Message: Changed read-time-stamp-counter to return two 29-bit fixnums, which seems more useful for most cases, even if the upper 6 bits are lost. Date: Fri Apr 23 09:00:10 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.11 movitz/losp/los0.lisp:1.12 --- movitz/losp/los0.lisp:1.11 Tue Apr 6 20:35:51 2004 +++ movitz/losp/los0.lisp Fri Apr 23 09:00:08 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.11 2004/04/07 00:35:51 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.12 2004/04/23 13:00:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -94,11 +94,12 @@ ;;; (format t "test-loop: ~S~%" ;;; (loop for i from 0 to 10 collect x))) ;;; -;;;(defun delay (time) -;;; (dotimes (i time) -;;; (with-inline-assembly (:returns :nothing) -;;; (:nop) -;;; (:nop)))) +#+ignore +(defun delay (time) + (dotimes (i time) + (with-inline-assembly (:returns :nothing) + (:nop) + (:nop)))) ;;; ;;;(defun test-consp (x) ;;; (with-inline-assembly (:returns :boolean-cf=1) @@ -106,6 +107,9 @@ ;;; (:leal (:edi -4) :eax) ;;; (:rorb :cl :al))) +(defun foo (x) + (foo x x)) + #+ignore (defun test-block (x) @@ -335,11 +339,16 @@ (error "Huh?")) #+ignore -(defun test-catch () +(defun test-catch (x) (catch 'test-tag - (test-throw 'test-tag) + (test-throw x 'test-tag) (format t "Hello world"))) +(defun test-throw (x tag) + (when x + (warn "Throwing ~S.." tag) + (throw tag (values-list x)))) + #+ignore (defun test-up-catch () (catch 'test-tag @@ -574,13 +583,12 @@ for s0 = (rtc-register :second) while (= x s0) finally (return s0)))) - (multiple-value-bind (c0-lo c0-mid c0-hi) + (multiple-value-bind (c0-lo c0-hi) (read-time-stamp-counter) (loop while (= s0 (rtc-register :second))) - (multiple-value-bind (c1-lo c1-mid c1-hi) + (multiple-value-bind (c1-lo c1-hi) (read-time-stamp-counter) - (+ (ash (- c1-hi c0-hi) 38) - (ash (- c1-mid c0-mid) 14) + (+ (ash (- c1-hi c0-hi) 20) (ash (+ 512 (- c1-lo c0-lo)) -10)))))) (defun report-cpu-frequency () @@ -589,6 +597,26 @@ (format t "~&CPU frequency: ~D.~2,'0D MHz.~%" mhz (round khz 10))) (values)) +(defvar *cpu-frequency-mhz*) + +(defun init-nano-sleep () + (setf *cpu-frequency-mhz* + (truncate (assess-cpu-frequency) 100))) + +(defun nano-sleep (nano-seconds) + (let* ((t0 (read-time-stamp-counter)) + (t1 (+ t0 (truncate (* nano-seconds (%symbol-global-value '*cpu-frequency-mhz*)) + 10000)))) + (when (< t1 t0) + (loop until (< (read-time-stamp-counter) t0))) ; wait for wrap-around + (loop until (>= (read-time-stamp-counter) t1)))) + +(defun test-nano-sleep (x) + (time (nano-sleep x))) + +(defun test () + (time 123)) + (defun mvtest () (multiple-value-call #'list (round 5 2)) (list (memref-int #x1000000 0 0 :unsigned-byte8) @@ -607,34 +635,36 @@ for s0 = (rtc-register :second) while (= x s0) finally (return s0)))) - (multiple-value-bind (c0-lo c0-mid c0-hi) + (multiple-value-bind (c0-lo c0-hi) (read-time-stamp-counter) (loop while (= s0 (rtc-register :second))) - (multiple-value-bind (c1-lo c1-mid c1-hi) + (multiple-value-bind (c1-lo c1-hi) (read-time-stamp-counter) - (let ((lo-res (+ (ash (- c1-hi c0-hi) 24) - (- c1-mid c0-mid)))) + (let ((res (+ (ash (- c1-hi c0-hi) 12) + (ash (- c1-lo c0-lo) -17)))) (cond - ((> lo-res 100) + ((> res 100) (setf (symbol-function 'get-internal-run-time) (lambda () - (multiple-value-bind (lo mid hi) + (multiple-value-bind (lo hi) (read-time-stamp-counter) - (declare (ignore lo)) - (dpb hi (byte 5 24) mid)))) - (setf internal-time-units-per-second lo-res)) + (+ (ash lo -17) + (ash (ldb (byte 10 0) hi) 12))))) + (setf internal-time-units-per-second res)) (t ;; This is for really slow machines, like bochs.. - (setf (symbol-function 'get-internal-run-time) - (lambda () - (multiple-value-bind (lo mid hi) - (read-time-stamp-counter) - (declare (ignore hi)) - (dpb mid - (byte 19 10) - (ldb (byte 10 14) lo))))) - (setf internal-time-units-per-second - (+ (ash (ldb (byte 19 0) (- c1-mid c0-mid)) 10) - (ldb (byte 10 14) (- c1-lo c0-lo)))))))))))) + (let ((res (+ (ash (- c1-hi c0-hi) 15) + (ash (- c1-lo c0-lo) -14)))) + (setf (symbol-function 'get-internal-run-time) + (lambda () + (multiple-value-bind (lo hi) + (read-time-stamp-counter) + (+ (ash lo -14) + (ash (ldb (byte 10 0) hi) 15))))) + (setf internal-time-units-per-second res))))))) + (warn "Internal-time will wrap in ~D days." + (truncate most-positive-fixnum + (* internal-time-units-per-second 60 60 24)))))) + ;;;(defun get-internal-run-time () ;;; (multiple-value-bind (lo mid hi) @@ -873,6 +903,11 @@ (error "What's up? [~S]" 'hey)) +(defun read (&optional input-stream eof-error-p eof-value recursive-p) + (declare (ignore input-stream recursive-p)) + (let ((string (muerte.readline:contextual-readline *repl-readline-context*))) + (simple-read-from-string string eof-error-p eof-value))) + (defun handle-warning (condition) (format t "Handle-warning: ~S" condition) (throw :debugger nil)) @@ -886,7 +921,7 @@ #+ignore (defun progntest () (unwind-protect - (progn (print 'x) 'foo 'bar) + (progn (print 'x) 'foo (error "bar")) (print 'y))) #+ignore @@ -944,6 +979,5 @@ (case (muerte.x86-pc.keyboard:poll-char) (#\esc (break "Under the bridge.")) (#\e (error "this is an error!")))))))) - (genesis) From ffjeld at common-lisp.net Fri Apr 23 13:00:18 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 23 Apr 2004 09:00:18 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/cpu-id.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv6368 Modified Files: cpu-id.lisp Log Message: Changed read-time-stamp-counter to return two 29-bit fixnums, which seems more useful for most cases, even if the upper 6 bits are lost. Date: Fri Apr 23 09:00:17 2004 Author: ffjeld Index: movitz/losp/muerte/cpu-id.lisp diff -u movitz/losp/muerte/cpu-id.lisp:1.3 movitz/losp/muerte/cpu-id.lisp:1.4 --- movitz/losp/muerte/cpu-id.lisp:1.3 Wed Apr 14 18:49:14 2004 +++ movitz/losp/muerte/cpu-id.lisp Fri Apr 23 09:00:17 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Apr 15 22:47:13 2002 ;;;; -;;;; $Id: cpu-id.lisp,v 1.3 2004/04/14 22:49:14 ffjeld Exp $ +;;;; $Id: cpu-id.lisp,v 1.4 2004/04/23 13:00:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -190,27 +190,56 @@ (defun read-time-stamp-counter () "Read the 64-bit i686 time-stamp counter. -Returned as three values: low 24 bits, mid 24 bits, high 16 bits. +Returned as two values: low 29 bits, mid 29 bits. This is an illegal instruction on lesser CPUs." (with-inline-assembly (:returns :multiple-values) (:std) (:rdtsc) ; Read Time-Stamp Counter into EDX:EAX - ;; Load upper 16 bits (of EDX) as ternary value. + (:shldl 5 :eax :edx) + (:shll #.movitz:+movitz-fixnum-shift+ :eax) + (:andl #.(cl:logxor #xffffffff movitz::+movitz-fixnum-zmask+) :edx) + (:andl #.(cl:* movitz:+movitz-fixnum-factor+ movitz:+movitz-most-positive-fixnum+) + :eax) (:movl :edx :ebx) - (:andl #xffff0000 :edx) - (:shll #.(cl:- 16 movitz::+movitz-fixnum-shift+) :edx) - ((:fs-override) :movl :edx (:edi #.(movitz::global-constant-offset 'values))) - ;; Bits 24-47 as fixnum into EBX - (:shldl #.(cl:+ 8 movitz::+movitz-fixnum-shift+) :eax :ebx) - (:andl #.(cl:* #x00ffffff movitz::+movitz-fixnum-factor+) :ebx) - ;; Bits 0-23 as fixnum into EAX - (:andl #x00ffffff :eax) - (:shll #.movitz::+movitz-fixnum-shift+ :eax) (:cld) - ;; Return 3 values - ((:fs-override) :movl 1 (:edi #.(movitz::global-constant-offset 'num-values))) - (:movl 3 :ecx) + (:movl 2 :ecx) (:stc))) + +(define-compiler-macro read-time-stamp-counter () + `(with-inline-assembly-case () + (do-case (:register :same) + (:std) + (:rdtsc) + (:movl :edi :edx) + (:leal ((:eax ,movitz:+movitz-fixnum-factor+)) (:result-register)) + (:cld)) + (do-case (t :multiple-values) + (:compile-form (:result-mode :multiple-values) (no-macro-call read-time-stamp-counter))))) + + +;;;(defun read-time-stamp-counter () +;;; "Read the 64-bit i686 time-stamp counter. +;;;Returned as three values: low 24 bits, mid 24 bits, high 16 bits. +;;;This is an illegal instruction on lesser CPUs." +;;; (with-inline-assembly (:returns :multiple-values) +;;; (:std) +;;; (:rdtsc) ; Read Time-Stamp Counter into EDX:EAX +;;; ;; Load upper 16 bits (of EDX) as ternary value. +;;; (:movl :edx :ecx) +;;; (:andl #xffff0000 :edx) +;;; (:shll #.(cl:- 16 movitz::+movitz-fixnum-shift+) :edx) +;;; ((:fs-override) :movl :edx (:edi #.(movitz::global-constant-offset 'values))) +;;; ;; Bits 24-47 as fixnum into EBX +;;; (:shldl #.(cl:+ 8 movitz::+movitz-fixnum-shift+) :eax :ebx) +;;; (:andl #.(cl:* #x00ffffff movitz::+movitz-fixnum-factor+) :ebx) +;;; ;; Bits 0-23 as fixnum into EAX +;;; (:andl #x00ffffff :eax) +;;; (:shll #.movitz::+movitz-fixnum-shift+ :eax) +;;; (:cld) +;;; ;; Return 3 values +;;; ((:fs-override) :movl 1 (:edi #.(movitz::global-constant-offset 'num-values))) +;;; (:movl 3 :ecx) +;;; (:stc))) (defun clear-time-stamp-counter () "Reset the i686 time-stamp-counter. From ffjeld at common-lisp.net Fri Apr 23 13:00:25 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 23 Apr 2004 09:00:25 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/environment.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7716 Modified Files: environment.lisp Log Message: Changed read-time-stamp-counter to return two 29-bit fixnums, which seems more useful for most cases, even if the upper 6 bits are lost. Date: Fri Apr 23 09:00:24 2004 Author: ffjeld Index: movitz/losp/muerte/environment.lisp diff -u movitz/losp/muerte/environment.lisp:1.5 movitz/losp/muerte/environment.lisp:1.6 --- movitz/losp/muerte/environment.lisp:1.5 Thu Mar 25 20:35:29 2004 +++ movitz/losp/muerte/environment.lisp Fri Apr 23 09:00:24 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Oct 20 00:41:57 2001 ;;;; -;;;; $Id: environment.lisp,v 1.5 2004/03/26 01:35:29 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.6 2004/04/23 13:00:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -120,28 +120,42 @@ (delete name *trace-map* :key 'car)))) (values)) +(defun time-skew-measure (mem x-lo x-hi) + (declare (ignore mem)) + (multiple-value-bind (y-lo y-hi) + (read-time-stamp-counter) + (assert (<= x-hi y-hi)) + (- y-lo x-lo (if (< y-lo x-lo) most-negative-fixnum 0)))) + +(defun report-time (start-mem start-time-lo start-time-hi) + (multiple-value-bind (end-time-lo end-time-hi) + (read-time-stamp-counter) + (let* ((skew (or (get 'report-time 'skew) + (setf (get 'report-time 'skew) + (multiple-value-bind (x-lo x-hi) + (read-time-stamp-counter) + (time-skew-measure start-mem x-lo x-hi))))) + (clumps (- (malloc-cons-pointer) start-mem)) + (delta-hi (- end-time-hi start-time-hi)) + (delta-lo (- end-time-lo start-time-lo skew))) + (if (= 0 delta-hi) + (format t "~&;; CPU cycles: ~D.~%;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~%" + delta-lo clumps clumps) + (format t "~&;; CPU cycles: ~DM.~%;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~%" + (+ (ash delta-hi 9) (ash delta-lo -20)) clumps clumps))))) + (defmacro time (form) `(let ((start-mem (malloc-cons-pointer))) (multiple-value-bind (start-time-lo start-time-hi) (read-time-stamp-counter) (multiple-value-prog1 ,form - (multiple-value-bind (end-time-lo end-time-hi) - (read-time-stamp-counter) - (let ((clumps (- (malloc-cons-pointer) start-mem)) - (delta-hi (- end-time-hi start-time-hi)) - (delta-lo (- end-time-lo start-time-lo))) - (if (< delta-hi #x1f) - (format t "~&;; CPU cycles: ~D.~%;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~%" - (+ (ash delta-hi 24) delta-lo) clumps clumps) - (format t "~&;; CPU cycles: ~D000.~%;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~%" - (+ (ash delta-hi 14) (ash delta-lo -10)) clumps clumps)))))))) + (report-time start-mem start-time-lo start-time-hi))))) (defun describe (object &optional stream) (describe-object object (output-stream-designator stream)) (values)) - (defmethod describe-object (object stream) (format stream "Don't know how to describe ~S." object)) From ffjeld at common-lisp.net Fri Apr 23 13:00:31 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 23 Apr 2004 09:00:31 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/eval.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7822 Modified Files: eval.lisp Log Message: Changed read-time-stamp-counter to return two 29-bit fixnums, which seems more useful for most cases, even if the upper 6 bits are lost. Date: Fri Apr 23 09:00:30 2004 Author: ffjeld Index: movitz/losp/muerte/eval.lisp diff -u movitz/losp/muerte/eval.lisp:1.7 movitz/losp/muerte/eval.lisp:1.8 --- movitz/losp/muerte/eval.lisp:1.7 Fri Apr 16 15:21:51 2004 +++ movitz/losp/muerte/eval.lisp Fri Apr 23 09:00:30 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 19 21:15:12 2001 ;;;; -;;;; $Id: eval.lisp,v 1.7 2004/04/16 19:21:51 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.8 2004/04/23 13:00:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -127,22 +127,7 @@ "Supposed to be the time macro." (cond ((cpu-featurep :tsc) - (let ((start-mem (malloc-cons-pointer))) - (multiple-value-bind (start-time-lo start-time-hi) - (read-time-stamp-counter) - (multiple-value-prog1 - (eval-form form env) - (multiple-value-bind (end-time-lo end-time-hi) - (read-time-stamp-counter) - (let ((clumps (- (malloc-cons-pointer) start-mem)) - (delta-hi (- end-time-hi start-time-hi)) - (delta-lo (- end-time-lo start-time-lo))) - (format t "~&;; Time report:") - (if (< delta-hi #x1f) - (format t "~&;; CPU cycles: ~D.~%;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~%" - (+ (ash delta-hi 24) delta-lo) clumps clumps) - (format t "~&;; CPU cycles: ~D000.~%;; Space used: ~D clumps = ~/muerte:pprint-clumps/.~%" - (+ (ash delta-hi 14) (ash delta-lo -10)) clumps clumps)))))))) + (time (eval-form form env))) (t (let ((start-mem (malloc-cons-pointer))) (multiple-value-prog1 (eval-form form env) From ffjeld at common-lisp.net Fri Apr 23 13:02:23 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 23 Apr 2004 09:02:23 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21872 Modified Files: integers.lisp Log Message: Fixed * a bit. Date: Fri Apr 23 09:02:23 2004 Author: ffjeld Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.7 movitz/losp/muerte/integers.lisp:1.8 --- movitz/losp/muerte/integers.lisp:1.7 Fri Apr 16 15:22:21 2004 +++ movitz/losp/muerte/integers.lisp Fri Apr 23 09:02:22 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.7 2004/04/16 19:22:21 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.8 2004/04/23 13:02:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -49,7 +49,7 @@ (t (let ((operands (loop for operand in operands if (movitz:movitz-constantp operand env) - sum (movitz::eval-form operand env) + sum (movitz:movitz-eval operand env) into constant-term else collect operand into non-constant-operands @@ -71,24 +71,24 @@ (define-compiler-macro +%2op (&whole form term1 term2) (cond ((and (movitz:movitz-constantp term1) ; first operand zero? - (zerop (movitz::eval-form term1))) + (zerop (movitz:movitz-eval term1))) term2) ; (+ 0 x) => x ((and (movitz:movitz-constantp term2) ; second operand zero? - (zerop (movitz::eval-form term2))) + (zerop (movitz:movitz-eval term2))) term1) ; (+ x 0) => x ((and (movitz:movitz-constantp term1) (movitz:movitz-constantp term2)) - (+ (movitz::eval-form term1) - (movitz::eval-form term2))) ; compile-time constant folding. + (+ (movitz:movitz-eval term1) + (movitz:movitz-eval term2))) ; compile-time constant folding. ((movitz:movitz-constantp term1) - (let ((constant-term1 (movitz::eval-form term1))) + (let ((constant-term1 (movitz:movitz-eval term1))) (check-type constant-term1 (signed-byte 30)) `(with-inline-assembly (:returns :register :side-effects nil) ; inline (:compile-form (:result-mode :register) ,term2) (:addl ,(* movitz::+movitz-fixnum-factor+ constant-term1) (:result-register)) (:into)))) ((movitz:movitz-constantp term2) - (let ((constant-term2 (movitz::eval-form term2))) + (let ((constant-term2 (movitz:movitz-eval term2))) (check-type constant-term2 (signed-byte 30)) `(with-inline-assembly (:returns :register :side-effects nil) ; inline (:compile-form (:result-mode :register) ,term1) @@ -164,20 +164,20 @@ (define-compiler-macro -%2op (&whole form minuend subtrahend) (cond ((and (movitz:movitz-constantp minuend) ; first operand zero? - (zerop (movitz::eval-form minuend))) + (zerop (movitz:movitz-eval minuend))) `(with-inline-assembly (:returns :register :side-effects nil) (:compile-form (:result-mode :register) ,subtrahend) (:negl (:result-register)) ; (- 0 x) => -x (:into))) ((and (movitz:movitz-constantp subtrahend) ; second operand zero? - (zerop (movitz::eval-form subtrahend))) - (movitz::eval-form minuend)) ; (- x 0) => x + (zerop (movitz:movitz-eval subtrahend))) + (movitz:movitz-eval minuend)) ; (- x 0) => x ((and (movitz:movitz-constantp minuend) (movitz:movitz-constantp subtrahend)) - (- (movitz::eval-form minuend) - (movitz::eval-form subtrahend))) ; compile-time constant folding. + (- (movitz:movitz-eval minuend) + (movitz:movitz-eval subtrahend))) ; compile-time constant folding. ((movitz:movitz-constantp minuend) - (let ((constant-minuend (movitz::eval-form minuend))) + (let ((constant-minuend (movitz:movitz-eval minuend))) (check-type constant-minuend (signed-byte 30)) `(with-inline-assembly (:returns :register :side-effects nil) ; inline (:compile-form (:result-mode :register) ,subtrahend) @@ -186,7 +186,7 @@ (:into) (:negl (:result-register))))) ((movitz:movitz-constantp subtrahend) - (let ((constant-subtrahend (movitz::eval-form subtrahend))) + (let ((constant-subtrahend (movitz:movitz-eval subtrahend))) (check-type constant-subtrahend (signed-byte 30)) `(+%2op ,minuend ,(- constant-subtrahend)))) (t `(with-inline-assembly (:returns :eax :side-effects nil) @@ -254,14 +254,14 @@ (cond ((and (movitz:movitz-constantp min env) (movitz:movitz-constantp max env)) - (let ((min (movitz::eval-form min env)) - (max (movitz::eval-form max env))) + (let ((min (movitz:movitz-eval min env)) + (max (movitz:movitz-eval max env))) (check-type min integer) (check-type max integer) ;; (warn "~D -- ~D" min max) (cond ((movitz:movitz-constantp x env) - (<= min (movitz::eval-form x env) max)) + (<= min (movitz:movitz-eval x env) max)) ((< max min) nil) ((= max min) @@ -295,7 +295,7 @@ (:adcl 0 :ecx)))))))) #+ignore ; this is buggy. ((movitz:movitz-constantp min env) - (let ((min (movitz::eval-form min env))) + (let ((min (movitz:movitz-eval min env))) (check-type min integer) (cond ((minusp min) @@ -396,7 +396,7 @@ (:compile-form (:result-mode :eax) ,x) (:testb ,movitz::+movitz-fixnum-zmask+ :al) (:jnz '(:sub-program (,below-not-integer) (:int 107))) - (:cmpl ,(* (movitz::eval-form max env) + (:cmpl ,(* (movitz:movitz-eval max env) movitz::+movitz-fixnum-factor+) :eax)) `(with-inline-assembly (:returns :boolean-cf=1) @@ -607,8 +607,11 @@ ((> 0 count #.(cl:- (cl:1- movitz::+movitz-fixnum-bits+))) `(with-inline-assembly (:returns :register :side-effects nil :type integer) , at load-integer - (:sarl ,(- count) (:result-register)) - (:andb #.(cl:logxor #xff movitz::+movitz-fixnum-zmask+) (:result-register-low8)))) + (:andl ,(ldb (byte 32 0) + (ash movitz:+movitz-most-positive-fixnum+ + (- movitz:+movitz-fixnum-shift+ count))) + (:result-register)) + (:sarl ,(- count) (:result-register)))) ((minusp count) `(if (minusp ,integer) -1 0)) (t `(if (= 0 ,integer) 0 (with-inline-assembly (:returns :non-local-exit) (:int 4))))))))))) @@ -641,12 +644,12 @@ (cond ((and (movitz:movitz-constantp factor1 env) (movitz:movitz-constantp factor2 env)) - (* (movitz::eval-form factor1 env) - (movitz::eval-form factor2 env))) + (* (movitz:movitz-eval factor1 env) + (movitz:movitz-eval factor2 env))) ((movitz:movitz-constantp factor2 env) - `(*%2op ,(movitz::eval-form factor2 env) ,factor1)) + `(*%2op ,(movitz:movitz-eval factor2 env) ,factor1)) ((movitz:movitz-constantp factor1 env) - (let ((f1 (movitz::eval-form factor1 env))) + (let ((f1 (movitz:movitz-eval factor1 env))) (check-type f1 integer) (case f1 (0 `(progn ,factor2 0)) @@ -658,17 +661,17 @@ (:jnz '(:sub-program () (:int 107))) (:imull ,f1 :eax :eax) (:into)))))) - (t form))) + (t `(no-macro-call * ,factor1 ,factor2)))) -(defun *%2op (factor1 factor2) - (check-type factor1 fixnum) - (check-type factor2 fixnum) - (with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :eax) factor1) - (:compile-form (:result-mode :ebx) factor2) - (:sarl #.movitz::+movitz-fixnum-shift+ :eax) - (:imull :ebx :eax :edx) - (:into))) +;;;(defun *%2op (factor1 factor2) +;;; (check-type factor1 fixnum) +;;; (check-type factor2 fixnum) +;;; (with-inline-assembly (:returns :eax) +;;; (:compile-form (:result-mode :eax) factor1) +;;; (:compile-form (:result-mode :ebx) factor2) +;;; (:sarl #.movitz::+movitz-fixnum-shift+ :eax) +;;; (:imull :ebx :eax :edx) +;;; (:into))) (define-compiler-macro * (&whole form &rest operands) (case (length operands) @@ -723,7 +726,7 @@ (define-compiler-macro truncate%2ops%1ret (&whole form &environment env number divisor) (cond ((movitz:movitz-constantp divisor env) - (let ((d (movitz::eval-form divisor env))) + (let ((d (movitz:movitz-eval divisor env))) (check-type d number) (case d (0 (error "Truncate by zero.")) @@ -1008,12 +1011,12 @@ (cond ((and (constant-bytespec-p bytespec) (movitz:movitz-constantp integer env)) - (ldb (byte (movitz::eval-form (second bytespec) env) - (movitz::eval-form (third bytespec) env)) - (movitz::eval-form integer env))) ; constant folding + (ldb (byte (movitz:movitz-eval (second bytespec) env) + (movitz:movitz-eval (third bytespec) env)) + (movitz:movitz-eval integer env))) ; constant folding ((constant-bytespec-p bytespec) - (let ((size (movitz::eval-form (second bytespec) env)) - (position (movitz::eval-form (third bytespec) env))) + (let ((size (movitz:movitz-eval (second bytespec) env)) + (position (movitz:movitz-eval (third bytespec) env))) (assert (<= (+ size position) 30)) `(with-inline-assembly (:returns :register :type integer) (:compile-form (:result-mode :register) ,integer) @@ -1022,7 +1025,6 @@ ,@(unless (zerop position) `((:shrl ,position (:result-register))))))) (t form)))) - (define-setf-expander ldb (bytespec int &environment env) "Stolen from the Hyperspec example in the define-setf-expander entry." From ffjeld at common-lisp.net Fri Apr 23 14:58:53 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 23 Apr 2004 10:58:53 -0400 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv1888 Modified Files: compiler.lisp Log Message: Improved compilation of dynamic-extent &rest arguments a bit. Especially functions with unused &rest parameters should be improved. Date: Fri Apr 23 10:58:53 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.58 movitz/compiler.lisp:1.59 --- movitz/compiler.lisp:1.58 Wed Apr 21 11:06:16 2004 +++ movitz/compiler.lisp Fri Apr 23 10:58:52 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.58 2004/04/21 15:06:16 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.59 2004/04/23 14:58:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -989,166 +989,163 @@ 1)) (t (error "make-2req confused by loc0: ~W, loc1: ~W" location-0 location-1))))) -#+ignore -(defun make-compiled-function-body-1rest (form funobj env top-level-p) - (when (and (null (required-vars env)) - (null (optional-vars env)) - (null (key-vars env)) - (rest-var env)) - (multiple-value-bind (code stack-frame-size use-stack-frame-p frame-map) - (make-compiled-body form funobj env top-level-p) - (let* ((rest-binding (movitz-binding (rest-var env) env nil)) - (edx-location (and (edx-var env) - (new-binding-location (edx-var env) frame-map - :default nil))) - (edx-code (when edx-location - `((:movl :edx (:ebp ,(stack-frame-offset edx-location))))))) - (cond - ((not (new-binding-located-p rest-binding frame-map)) - (append '(entry%1op - entry%2op - entry%3op) - (when use-stack-frame-p - +enter-stack-frame-code+) - '(start-stack-frame-setup) - (make-compiled-stack-frame-init stack-frame-size) - edx-code - code - (make-compiled-function-postlude funobj env use-stack-frame-p))) - (t ;; (new-binding-located-p rest-binding frame-map) - (let ((rest-location (new-binding-location rest-binding frame-map))) - (values (append +enter-stack-frame-code+ - '(start-stack-frame-setup) - (make-compiled-stack-frame-init stack-frame-size) - `((:movl :edi (:ebp ,(stack-frame-offset rest-location)))) - edx-code - `((:testb :cl :cl) - (:jz 'end-stack-frame-setup) - (:js '(:sub-program (normalize-ecx) - (:shrl 8 :ecx) - (:jmp 'ecx-ok))) - (:andl #x7f :ecx) - ecx-ok - (:xorl :edx :edx) - (:call (:edi ,(global-constant-offset 'restify-dynamic-extent))) - (:movl :eax (:ebp ,(stack-frame-offset rest-location))) - (:jmp 'end-stack-frame-setup)) - `(entry%1op - , at +enter-stack-frame-code+ - ,@(make-compiled-stack-frame-init stack-frame-size) - , at edx-code - (:andl -8 :esp) - (:pushl :edi) - (:pushl :eax) - (:leal (:esp 1) :ecx) - (:movl :ecx (:ebp ,(stack-frame-offset rest-location))) - (:jmp 'end-stack-frame-setup)) - `(entry%2op - , at +enter-stack-frame-code+ - ,@(make-compiled-stack-frame-init stack-frame-size) - , at edx-code - (:andl -8 :esp) - (:pushl :edi) - (:pushl :ebx) - (:leal (:esp 1) :ecx) - (:pushl :ecx) - (:pushl :eax) - (:leal (:esp 1) :ecx) - (:movl :ecx (:ebp ,(stack-frame-offset rest-location))) - (:jmp 'end-stack-frame-setup)) - '(end-stack-frame-setup) - code - (make-compiled-function-postlude funobj env t)) - use-stack-frame-p)))))))) +;;;(defun make-compiled-function-body-1rest (form funobj env top-level-p) +;;; (when (and (null (required-vars env)) +;;; (null (optional-vars env)) +;;; (null (key-vars env)) +;;; (rest-var env)) +;;; (multiple-value-bind (code stack-frame-size use-stack-frame-p frame-map) +;;; (make-compiled-body form funobj env top-level-p) +;;; (let* ((rest-binding (movitz-binding (rest-var env) env nil)) +;;; (edx-location (and (edx-var env) +;;; (new-binding-location (edx-var env) frame-map +;;; :default nil))) +;;; (edx-code (when edx-location +;;; `((:movl :edx (:ebp ,(stack-frame-offset edx-location))))))) +;;; (cond +;;; ((not (new-binding-located-p rest-binding frame-map)) +;;; (append '(entry%1op +;;; entry%2op +;;; entry%3op) +;;; (when use-stack-frame-p +;;; +enter-stack-frame-code+) +;;; '(start-stack-frame-setup) +;;; (make-compiled-stack-frame-init stack-frame-size) +;;; edx-code +;;; code +;;; (make-compiled-function-postlude funobj env use-stack-frame-p))) +;;; (t ;; (new-binding-located-p rest-binding frame-map) +;;; (let ((rest-location (new-binding-location rest-binding frame-map))) +;;; (values (append +enter-stack-frame-code+ +;;; '(start-stack-frame-setup) +;;; (make-compiled-stack-frame-init stack-frame-size) +;;; `((:movl :edi (:ebp ,(stack-frame-offset rest-location)))) +;;; edx-code +;;; `((:testb :cl :cl) +;;; (:jz 'end-stack-frame-setup) +;;; (:js '(:sub-program (normalize-ecx) +;;; (:shrl 8 :ecx) +;;; (:jmp 'ecx-ok))) +;;; (:andl #x7f :ecx) +;;; ecx-ok +;;; (:xorl :edx :edx) +;;; (:call (:edi ,(global-constant-offset 'restify-dynamic-extent))) +;;; (:movl :eax (:ebp ,(stack-frame-offset rest-location))) +;;; (:jmp 'end-stack-frame-setup)) +;;; `(entry%1op +;;; , at +enter-stack-frame-code+ +;;; ,@(make-compiled-stack-frame-init stack-frame-size) +;;; , at edx-code +;;; (:andl -8 :esp) +;;; (:pushl :edi) +;;; (:pushl :eax) +;;; (:leal (:esp 1) :ecx) +;;; (:movl :ecx (:ebp ,(stack-frame-offset rest-location))) +;;; (:jmp 'end-stack-frame-setup)) +;;; `(entry%2op +;;; , at +enter-stack-frame-code+ +;;; ,@(make-compiled-stack-frame-init stack-frame-size) +;;; , at edx-code +;;; (:andl -8 :esp) +;;; (:pushl :edi) +;;; (:pushl :ebx) +;;; (:leal (:esp 1) :ecx) +;;; (:pushl :ecx) +;;; (:pushl :eax) +;;; (:leal (:esp 1) :ecx) +;;; (:movl :ecx (:ebp ,(stack-frame-offset rest-location))) +;;; (:jmp 'end-stack-frame-setup)) +;;; '(end-stack-frame-setup) +;;; code +;;; (make-compiled-function-postlude funobj env t)) +;;; use-stack-frame-p)))))))) - -#+ignore -(defun make-compiled-function-body-1req-1opt (form funobj env top-level-p) - (when (and (= 1 (length (required-vars env))) - (= 1 (length (optional-vars env))) - (= 0 (length (key-vars env))) - (null (rest-var env))) - (let* ((opt-var (first (optional-vars env))) - (opt-binding (movitz-binding opt-var env nil)) - (req-binding (movitz-binding (first (required-vars env)) env nil)) - (default-form (optional-function-argument-init-form opt-binding))) - (compiler-values-bind (&code opt-default-code &producer opt-default-producer) - (compiler-call #'compile-form - :form default-form - :result-mode :push - :env env - :funobj funobj) - (cond - ((eq 'compile-self-evaluating opt-default-producer) - (multiple-value-bind (code stack-frame-size use-stack-frame-p frame-map) - (make-compiled-body form funobj env top-level-p nil (list opt-default-code)) - (declare (ignore use-stack-frame-p)) - (let ((use-stack-frame-p t)) - (cond - ((and (new-binding-located-p req-binding frame-map) - (new-binding-located-p opt-binding frame-map)) - (multiple-value-bind (eax-ebx-code eax-ebx-stack-offset) - (ecase (new-binding-location req-binding frame-map) - ;; might well be more cases here, but let's wait till they show up.. - (:eax (values nil 0)) - (1 (values '((:pushl :eax)) 1))) - ;; (warn "defc: ~S" opt-default-code) - (let ((stack-init-size (- stack-frame-size eax-ebx-stack-offset)) - (installed-default-code (finalize-code opt-default-code funobj env frame-map))) - (values (append `((:call (:edi ,(global-constant-offset 'decode-args-1or2))) - entry%2op - (:pushl :ebp) - (:movl :esp :ebp) - (:pushl :esi) - start-stack-frame-setup - , at eax-ebx-code - ,@(if (eql (1+ eax-ebx-stack-offset) - (new-binding-location opt-binding frame-map)) - (append `((:pushl :ebx)) - (make-compiled-stack-frame-init (1- stack-init-size))) - (append (make-compiled-stack-frame-init stack-init-size) - `((:movl :ebx (:ebp ,(stack-frame-offset - (new-binding-location opt-binding - frame-map))))))) - (:jmp 'arg-init-done) - entry%1op - (:pushl :ebp) - (:movl :esp :ebp) - (:pushl :esi) - , at eax-ebx-code - ,@(if (eql (1+ eax-ebx-stack-offset) - (new-binding-location opt-binding frame-map)) - (append installed-default-code - (make-compiled-stack-frame-init (1- stack-init-size))) - (append (make-compiled-stack-frame-init stack-init-size) - installed-default-code - `((:popl (:ebp ,(stack-frame-offset - (new-binding-location opt-binding - frame-map))))))) - arg-init-done) - code - (make-compiled-function-postlude funobj env t)) - use-stack-frame-p)))) - ((and (new-binding-located-p req-binding frame-map) - (not (new-binding-located-p opt-binding frame-map))) - (multiple-value-bind (eax-code eax-stack-offset) - (ecase (new-binding-location req-binding frame-map) - (:eax (values nil 0)) - (1 (values '((:pushl :eax)) 1))) - (values (append `((:call (:edi ,(global-constant-offset 'decode-args-1or2))) - ;; (:jmp 'decode-numargs) - entry%1op - entry%2op - (:pushl :ebp) - (:movl :esp :ebp) - (:pushl :esi)) - eax-code - (make-compiled-stack-frame-init (- stack-frame-size eax-stack-offset)) - code - (make-compiled-function-postlude funobj env t)) - use-stack-frame-p))) - (t (warn "1-req-1-opt failed")))))) - (t nil)))))) +;;;(defun make-compiled-function-body-1req-1opt (form funobj env top-level-p) +;;; (when (and (= 1 (length (required-vars env))) +;;; (= 1 (length (optional-vars env))) +;;; (= 0 (length (key-vars env))) +;;; (null (rest-var env))) +;;; (let* ((opt-var (first (optional-vars env))) +;;; (opt-binding (movitz-binding opt-var env nil)) +;;; (req-binding (movitz-binding (first (required-vars env)) env nil)) +;;; (default-form (optional-function-argument-init-form opt-binding))) +;;; (compiler-values-bind (&code opt-default-code &producer opt-default-producer) +;;; (compiler-call #'compile-form +;;; :form default-form +;;; :result-mode :push +;;; :env env +;;; :funobj funobj) +;;; (cond +;;; ((eq 'compile-self-evaluating opt-default-producer) +;;; (multiple-value-bind (code stack-frame-size use-stack-frame-p frame-map) +;;; (make-compiled-body form funobj env top-level-p nil (list opt-default-code)) +;;; (declare (ignore use-stack-frame-p)) +;;; (let ((use-stack-frame-p t)) +;;; (cond +;;; ((and (new-binding-located-p req-binding frame-map) +;;; (new-binding-located-p opt-binding frame-map)) +;;; (multiple-value-bind (eax-ebx-code eax-ebx-stack-offset) +;;; (ecase (new-binding-location req-binding frame-map) +;;; ;; might well be more cases here, but let's wait till they show up.. +;;; (:eax (values nil 0)) +;;; (1 (values '((:pushl :eax)) 1))) +;;; ;; (warn "defc: ~S" opt-default-code) +;;; (let ((stack-init-size (- stack-frame-size eax-ebx-stack-offset)) +;;; (installed-default-code (finalize-code opt-default-code funobj env frame-map))) +;;; (values (append `((:call (:edi ,(global-constant-offset 'decode-args-1or2))) +;;; entry%2op +;;; (:pushl :ebp) +;;; (:movl :esp :ebp) +;;; (:pushl :esi) +;;; start-stack-frame-setup +;;; , at eax-ebx-code +;;; ,@(if (eql (1+ eax-ebx-stack-offset) +;;; (new-binding-location opt-binding frame-map)) +;;; (append `((:pushl :ebx)) +;;; (make-compiled-stack-frame-init (1- stack-init-size))) +;;; (append (make-compiled-stack-frame-init stack-init-size) +;;; `((:movl :ebx (:ebp ,(stack-frame-offset +;;; (new-binding-location opt-binding +;;; frame-map))))))) +;;; (:jmp 'arg-init-done) +;;; entry%1op +;;; (:pushl :ebp) +;;; (:movl :esp :ebp) +;;; (:pushl :esi) +;;; , at eax-ebx-code +;;; ,@(if (eql (1+ eax-ebx-stack-offset) +;;; (new-binding-location opt-binding frame-map)) +;;; (append installed-default-code +;;; (make-compiled-stack-frame-init (1- stack-init-size))) +;;; (append (make-compiled-stack-frame-init stack-init-size) +;;; installed-default-code +;;; `((:popl (:ebp ,(stack-frame-offset +;;; (new-binding-location opt-binding +;;; frame-map))))))) +;;; arg-init-done) +;;; code +;;; (make-compiled-function-postlude funobj env t)) +;;; use-stack-frame-p)))) +;;; ((and (new-binding-located-p req-binding frame-map) +;;; (not (new-binding-located-p opt-binding frame-map))) +;;; (multiple-value-bind (eax-code eax-stack-offset) +;;; (ecase (new-binding-location req-binding frame-map) +;;; (:eax (values nil 0)) +;;; (1 (values '((:pushl :eax)) 1))) +;;; (values (append `((:call (:edi ,(global-constant-offset 'decode-args-1or2))) +;;; ;; (:jmp 'decode-numargs) +;;; entry%1op +;;; entry%2op +;;; (:pushl :ebp) +;;; (:movl :esp :ebp) +;;; (:pushl :esi)) +;;; eax-code +;;; (make-compiled-stack-frame-init (- stack-frame-size eax-stack-offset)) +;;; code +;;; (make-compiled-function-postlude funobj env t)) +;;; use-stack-frame-p))) +;;; (t (warn "1-req-1-opt failed")))))) +;;; (t nil)))))) (defun make-compiled-stack-frame-init (stack-frame-init) @@ -4218,14 +4215,15 @@ (when rest-var (let* ((rest-binding (movitz-binding rest-var env)) (rest-position (function-argument-argnum rest-binding))) + #+ignore (assert (or (typep rest-binding 'hidden-rest-function-argument) - (movitz-env-get rest-var 'dynamic-extent nil env) - (movitz-env-get rest-var 'ignore nil env)) + (movitz-env-get rest-var 'dynamic-extent nil env)) () "&REST variable ~S must be dynamic-extent." rest-var) - (setq need-normalized-ecx-p t) - (append (make-immediate-move rest-position :edx) - `((:call (:edi ,(global-constant-offset 'restify-dynamic-extent))) + ;; (setq need-normalized-ecx-p t) + (append #+ignore (make-immediate-move rest-position :edx) + `(#+ignore + (:call (:edi ,(global-constant-offset 'restify-dynamic-extent))) (:init-lexvar ,rest-binding :init-with-register :eax :init-with-type list))))) @@ -5755,27 +5753,53 @@ (declare (ignore protect-carry)) ; nothing modifies carry anyway. (assert (eq binding (ensure-local-binding binding funobj))) (cond - ((binding-lended-p binding) - (let ((cons-position (getf (binding-lended-p binding) - :stack-cons-location)) - (tmp-register (find-if (lambda (r) - (and (not (member r protect-registers)) - (not (eq r init-with-register)))) - '(:edx :ecx :ebx :eax))) - (init-register (or init-with-register :edi))) - (when init-with-register - (assert (not (null init-with-type)))) - (assert tmp-register () ; solve this with push eax .. pop eax if ever needed. - "Unable to find a tmp-register for ~S." instruction) - `((:leal (:ebp ,(1+ (stack-frame-offset (1+ cons-position)))) - ,tmp-register) - (:movl :edi (,tmp-register 3)) ; cdr - (:movl ,init-register (,tmp-register -1)) ; car - (:movl ,tmp-register - (:ebp ,(stack-frame-offset - (new-binding-location binding frame-map))))))) - (init-with-register - (make-store-lexical binding init-with-register nil frame-map))))) + ((not (new-binding-located-p binding frame-map)) + (unless (or (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding)) + (movitz-env-get (binding-name binding) 'ignorable nil (binding-env binding))) + (warn "Unused variable: ~S." (binding-name binding)))) + (t (when (movitz-env-get (binding-name binding) 'ignore nil (binding-env binding)) + (warn "Variable ~S used while declared ignored." (binding-name binding))) + (append + (cond + ((typep binding 'rest-function-argument) + (assert (eq :eax init-with-register)) + (assert (or (typep binding 'hidden-rest-function-argument) + (movitz-env-get (binding-name binding) + 'dynamic-extent nil (binding-env binding))) + () + "&REST variable ~S must be dynamic-extent." (binding-name binding)) + (setf (need-normalized-ecx-p (find-function-env (binding-env binding) + funobj)) + t) + (append (make-immediate-move (function-argument-argnum binding) :edx) + `((:call (:edi ,(global-constant-offset 'restify-dynamic-extent)))) + #+ignore + (unless (or (typep binding 'hidden-rest-function-argument) + (movitz-env-get (binding-name binding) + 'dynamic-extent nil (binding-env binding))) + (make-compiled-funcall-by-symbol 'muerte.cl:copy-list 1 funobj))))) + (cond + ((binding-lended-p binding) + (let ((cons-position (getf (binding-lended-p binding) + :stack-cons-location)) + (tmp-register (find-if (lambda (r) + (and (not (member r protect-registers)) + (not (eq r init-with-register)))) + '(:edx :ecx :ebx :eax))) + (init-register (or init-with-register :edi))) + (when init-with-register + (assert (not (null init-with-type)))) + (assert tmp-register () ; solve this with push eax .. pop eax if ever needed. + "Unable to find a tmp-register for ~S." instruction) + `((:leal (:ebp ,(1+ (stack-frame-offset (1+ cons-position)))) + ,tmp-register) + (:movl :edi (,tmp-register 3)) ; cdr + (:movl ,init-register (,tmp-register -1)) ; car + (:movl ,tmp-register + (:ebp ,(stack-frame-offset + (new-binding-location binding frame-map))))))) + (init-with-register + (make-store-lexical binding init-with-register nil frame-map)))))))) ;;;;;;;;;;;;;;;;;; car From ffjeld at common-lisp.net Fri Apr 23 14:59:35 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 23 Apr 2004 10:59:35 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/lib/repl.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv9890 Modified Files: repl.lisp Log Message: Slightly better default-repl-prompter. Date: Fri Apr 23 10:59:35 2004 Author: ffjeld Index: movitz/losp/lib/repl.lisp diff -u movitz/losp/lib/repl.lisp:1.10 movitz/losp/lib/repl.lisp:1.11 --- movitz/losp/lib/repl.lisp:1.10 Tue Apr 6 10:37:04 2004 +++ movitz/losp/lib/repl.lisp Fri Apr 23 10:59:35 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Mar 19 14:58:12 2003 ;;;; -;;;; $Id: repl.lisp,v 1.10 2004/04/06 14:37:04 ffjeld Exp $ +;;;; $Id: repl.lisp,v 1.11 2004/04/23 14:59:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -29,7 +29,7 @@ (defun default-repl-prompter () (fresh-line) - (when (plusp *repl-level*) + (when (or (plusp *repl-level*) *repl-prompt-context*) (format t "[~D~@[~A~]] " *repl-level* *repl-prompt-context*)) (format t "~A> " (package-name *package*))) From ffjeld at common-lisp.net Fri Apr 23 14:59:55 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 23 Apr 2004 10:59:55 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/arrays.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13561 Modified Files: arrays.lisp Log Message: Minor edits. Date: Fri Apr 23 10:59:55 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.17 movitz/losp/muerte/arrays.lisp:1.18 --- movitz/losp/muerte/arrays.lisp:1.17 Fri Apr 16 10:42:51 2004 +++ movitz/losp/muerte/arrays.lisp Fri Apr 23 10:59:55 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.17 2004/04/16 14:42:51 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.18 2004/04/23 14:59:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -250,8 +250,7 @@ done)) (t (vector &rest subscripts) - (declare (dynamic-extent subscripts) - (ignore vector subscripts)) + (declare (ignore vector subscripts)) (error "Multi-dimensional arrays not implemented.")))) (defun (setf aref) (value vector &rest subscripts) @@ -334,8 +333,7 @@ (:compile-form (:result-mode :ignore) (error "Not a vector: ~S" vector)) done)) (t (value vector &rest subscripts) - (declare (dynamic-extent subscripts) - (ignore value vector subscripts)) + (declare (ignore value vector subscripts)) (error "Multi-dimensional arrays not implemented.")))) From ffjeld at common-lisp.net Fri Apr 23 15:00:14 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 23 Apr 2004 11:00:14 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/common-lisp.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18950 Modified Files: common-lisp.lisp Log Message: Re-ordered some files. Date: Fri Apr 23 11:00:14 2004 Author: ffjeld Index: movitz/losp/muerte/common-lisp.lisp diff -u movitz/losp/muerte/common-lisp.lisp:1.6 movitz/losp/muerte/common-lisp.lisp:1.7 --- movitz/losp/muerte/common-lisp.lisp:1.6 Mon Apr 19 18:38:11 2004 +++ movitz/losp/muerte/common-lisp.lisp Fri Apr 23 11:00:14 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:41:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: common-lisp.lisp,v 1.6 2004/04/19 22:38:11 ffjeld Exp $ +;;;; $Id: common-lisp.lisp,v 1.7 2004/04/23 15:00:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -41,8 +41,8 @@ (require :muerte/format) (require :muerte/error) (require :muerte/loop) -(require :muerte/eval) (require :muerte/environment) +(require :muerte/eval) (require :muerte/streams) (require :muerte/restarts) (require :muerte/conditions) From ffjeld at common-lisp.net Fri Apr 23 15:01:56 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 23 Apr 2004 11:01:56 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/read.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25312 Modified Files: read.lisp Log Message: Removed some debugging code. Date: Fri Apr 23 11:01:56 2004 Author: ffjeld Index: movitz/losp/muerte/read.lisp diff -u movitz/losp/muerte/read.lisp:1.3 movitz/losp/muerte/read.lisp:1.4 --- movitz/losp/muerte/read.lisp:1.3 Tue Apr 13 10:21:14 2004 +++ movitz/losp/muerte/read.lisp Fri Apr 23 11:01:56 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Oct 17 21:50:42 2001 ;;;; -;;;; $Id: read.lisp,v 1.3 2004/04/13 14:21:14 ffjeld Exp $ +;;;; $Id: read.lisp,v 1.4 2004/04/23 15:01:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -188,9 +188,7 @@ (setf string next-string end next-string-end)) (setf i (1- element-end)) - (if (match-caller 'eval-time) - (time (push element list)) - (push element list))))))))) + (push element list)))))))) (simple-read-delimited-list delimiter next-string next-start next-end :tail-delimiter tail-delimiter :list list))) From ffjeld at common-lisp.net Fri Apr 23 15:02:20 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 23 Apr 2004 11:02:20 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/sequences.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27383 Modified Files: sequences.lisp Log Message: Minor edits. Date: Fri Apr 23 11:02:20 2004 Author: ffjeld Index: movitz/losp/muerte/sequences.lisp diff -u movitz/losp/muerte/sequences.lisp:1.6 movitz/losp/muerte/sequences.lisp:1.7 --- movitz/losp/muerte/sequences.lisp:1.6 Wed Mar 31 07:17:14 2004 +++ movitz/losp/muerte/sequences.lisp Fri Apr 23 11:02:20 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.6 2004/03/31 12:17:14 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.7 2004/04/23 15:02:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -591,8 +591,7 @@ (mapf (first-sequence-ref i) (second-sequence-ref j)))))) ))) (t (function first-sequence &rest more-sequences) - (declare (dynamic-extent more-sequences) - (ignore function first-sequence more-sequences)) + (declare (ignore function first-sequence more-sequences)) (error "MAP not implemented.")))) (defun map-for-list (function first-sequence &rest more-sequences) From ffjeld at common-lisp.net Fri Apr 23 15:02:59 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 23 Apr 2004 11:02:59 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/environment.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29228 Modified Files: environment.lisp Log Message: Somewhat improved skew calculation in report-time. Date: Fri Apr 23 11:02:59 2004 Author: ffjeld Index: movitz/losp/muerte/environment.lisp diff -u movitz/losp/muerte/environment.lisp:1.6 movitz/losp/muerte/environment.lisp:1.7 --- movitz/losp/muerte/environment.lisp:1.6 Fri Apr 23 09:00:24 2004 +++ movitz/losp/muerte/environment.lisp Fri Apr 23 11:02:59 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Oct 20 00:41:57 2001 ;;;; -;;;; $Id: environment.lisp,v 1.6 2004/04/23 13:00:24 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.7 2004/04/23 15:02:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -132,9 +132,12 @@ (read-time-stamp-counter) (let* ((skew (or (get 'report-time 'skew) (setf (get 'report-time 'skew) - (multiple-value-bind (x-lo x-hi) - (read-time-stamp-counter) - (time-skew-measure start-mem x-lo x-hi))))) + (loop repeat 10 ; warm up caches. + as x = (multiple-value-bind (x-lo x-hi) + (read-time-stamp-counter) + (constantly-true 123) + (time-skew-measure start-mem x-lo x-hi)) + finally (return x))))) (clumps (- (malloc-cons-pointer) start-mem)) (delta-hi (- end-time-hi start-time-hi)) (delta-lo (- end-time-lo start-time-lo skew))) From ffjeld at common-lisp.net Fri Apr 23 15:04:07 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 23 Apr 2004 11:04:07 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv5952 Modified Files: los0.lisp Log Message: Added the pci.lisp file. Date: Fri Apr 23 11:04:07 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.12 movitz/losp/los0.lisp:1.13 --- movitz/losp/los0.lisp:1.12 Fri Apr 23 09:00:08 2004 +++ movitz/losp/los0.lisp Fri Apr 23 11:04:07 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.12 2004/04/23 13:00:08 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.13 2004/04/23 15:04:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -627,43 +627,38 @@ ;;;;;;;;;;;;;;; CL -(defun install-internal-time () +(defun install-internal-time (&optional (minimum-frequency 100)) "Figure out this CPU's internal-time-unit. Warning: This process takes about 1.5 seconds." - (if (not (cpu-featurep :tsc)) - (warn "This CPU has no time-stamp-counter. Timer-related functions will not work.") - (let ((s0 (loop with x = (rtc-register :second) - for s0 = (rtc-register :second) - while (= x s0) - finally (return s0)))) - (multiple-value-bind (c0-lo c0-hi) + (let ((s0 (loop with x = (rtc-register :second) + for s0 = (rtc-register :second) + while (= x s0) + finally (return s0)))) + (multiple-value-bind (c0-lo c0-hi) + (read-time-stamp-counter) + (loop while (= s0 (rtc-register :second))) + (multiple-value-bind (c1-lo c1-hi) (read-time-stamp-counter) - (loop while (= s0 (rtc-register :second))) - (multiple-value-bind (c1-lo c1-hi) - (read-time-stamp-counter) - (let ((res (+ (ash (- c1-hi c0-hi) 12) - (ash (- c1-lo c0-lo) -17)))) - (cond - ((> res 100) + (let ((res (+ (ash (ldb (byte 22 0) (- c1-hi c0-hi)) 7) + (ash (- c1-lo c0-lo) -22)))) + (cond + ((> res minimum-frequency) + (setf (symbol-function 'get-internal-run-time) + (lambda () + (multiple-value-bind (lo hi) + (read-time-stamp-counter) + (+ (ash lo -22) + (ash (ldb (byte 22 0) hi) 7))))) + (setf internal-time-units-per-second res)) + (t ;; This is for really slow machines, like bochs.. + (let ((res (+ (ash (- c1-hi c0-hi) 13) + (ash (- c1-lo c0-lo) -16)))) (setf (symbol-function 'get-internal-run-time) (lambda () (multiple-value-bind (lo hi) (read-time-stamp-counter) - (+ (ash lo -17) - (ash (ldb (byte 10 0) hi) 12))))) - (setf internal-time-units-per-second res)) - (t ;; This is for really slow machines, like bochs.. - (let ((res (+ (ash (- c1-hi c0-hi) 15) - (ash (- c1-lo c0-lo) -14)))) - (setf (symbol-function 'get-internal-run-time) - (lambda () - (multiple-value-bind (lo hi) - (read-time-stamp-counter) - (+ (ash lo -14) - (ash (ldb (byte 10 0) hi) 15))))) - (setf internal-time-units-per-second res))))))) - (warn "Internal-time will wrap in ~D days." - (truncate most-positive-fixnum - (* internal-time-units-per-second 60 60 24)))))) + (+ (ash (ldb (byte 16 0) hi) 13) + (ash lo -16))))) + (setf internal-time-units-per-second res))))))))) ;;;(defun get-internal-run-time () @@ -865,9 +860,7 @@ (incf extended-memsize (io-port #x71 :unsigned-byte8)) (format t "Extended memory: ~D KB" extended-memsize)) -;;; (loop for i from #x40600 below #x80000 -;;; do (setf (memref i 0 0 :unsigned-byte32) #xababe13)) - + (idt-init) (install-los0-consing) (let ((*repl-readline-context* (make-readline-context :history-size 16)) @@ -875,17 +868,22 @@ #+ignore (*error-no-condition-for-debugger* t) (*debugger-function* #'los0-debugger) (*package* nil)) - (with-simple-restart (continue "Abort LOS0 boot-up initialization.") + (with-simple-restart (abort "Skip Los0 boot-up initialization.") (setf *cpu-features* (find-cpu-features)) (format t "~&CPU features:~:[ none~;~{ ~A~#[~; and~:;,~]~}~].~%" *cpu-features* *cpu-features*) - (install-internal-time) - (funcall #'idt-init) ;; (muerte:asm :int 49) (setf *package* (find-package "INIT")) (clos-bootstrap) + (cond + ((not (cpu-featurep :tsc)) + (warn "This CPU has no time-stamp-counter. Timer-related functions will not work.")) + (t (install-internal-time) + (warn "Internal-time will wrap in ~D days." + (truncate most-positive-fixnum + (* internal-time-units-per-second 60 60 24))))) ;; (muerte.toplevel:invoke-toplevel-command :mapkey #\newline) #+ignore (let ((s (make-instance 'muerte.x86-pc:vga-text-console))) (setf *standard-output* s From ffjeld at common-lisp.net Fri Apr 23 15:04:12 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 23 Apr 2004 11:04:12 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/all.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv6454 Modified Files: all.lisp Log Message: Added the pci.lisp file. Date: Fri Apr 23 11:04:12 2004 Author: ffjeld Index: movitz/losp/x86-pc/all.lisp diff -u movitz/losp/x86-pc/all.lisp:1.3 movitz/losp/x86-pc/all.lisp:1.4 --- movitz/losp/x86-pc/all.lisp:1.3 Mon Jan 19 06:23:51 2004 +++ movitz/losp/x86-pc/all.lisp Fri Apr 23 11:04:12 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Sep 27 21:14:56 2001 ;;;; -;;;; $Id: all.lisp,v 1.3 2004/01/19 11:23:51 ffjeld Exp $ +;;;; $Id: all.lisp,v 1.4 2004/04/23 15:04:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -23,6 +23,7 @@ (require :x86-pc/pit8253) (require :x86-pc/interrupt) (require :x86-pc/cmos) +(require :x86-pc/pci) ;; (require :x86-pc/serial) (require :x86-pc/textmode-console) (require :x86-pc/debugger) From ffjeld at common-lisp.net Fri Apr 23 15:04:17 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 23 Apr 2004 11:04:17 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/pci.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv7815 Modified Files: pci.lisp Log Message: Added the pci.lisp file. Date: Fri Apr 23 11:04:17 2004 Author: ffjeld Index: movitz/losp/x86-pc/pci.lisp diff -u movitz/losp/x86-pc/pci.lisp:1.1.1.1 movitz/losp/x86-pc/pci.lisp:1.2 --- movitz/losp/x86-pc/pci.lisp:1.1.1.1 Tue Jan 13 06:05:06 2004 +++ movitz/losp/x86-pc/pci.lisp Fri Apr 23 11:04:17 2004 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2003, +;;;; Copyright (C) 2003-2004, ;;;; Department of Computer Science, University of Tromsoe, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,11 +10,13 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sun Dec 14 22:33:42 2003 ;;;; -;;;; $Id: pci.lisp,v 1.1.1.1 2004/01/13 11:05:06 ffjeld Exp $ +;;;; $Id: pci.lisp,v 1.2 2004/04/23 15:04:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (in-package muerte.x86-pc) + +(provide :x86-pc/pci) (defun bios32-find () (loop for bios32 from #xe0000 to #xffff0 by 16 From ffjeld at common-lisp.net Fri Apr 23 15:05:35 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 23 Apr 2004 11:05:35 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv14221 Modified Files: functions.lisp Log Message: Added special-cased compilation of (constantly t) and (constantly nil). Date: Fri Apr 23 11:05:35 2004 Author: ffjeld Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.10 movitz/losp/muerte/functions.lisp:1.11 --- movitz/losp/muerte/functions.lisp:1.10 Sun Apr 18 19:18:31 2004 +++ movitz/losp/muerte/functions.lisp Fri Apr 23 11:05:35 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.10 2004/04/18 23:18:31 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.11 2004/04/23 15:05:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -26,13 +26,24 @@ (declare (ignore ignore)) 'value) -(define-compiler-macro constantly (&whole form value-form) +(defun constantly-true (&rest ignore) + (declare (ignore ignore)) + t) + +(defun constantly-false (&rest ignore) + (declare (ignore ignore)) + nil) + +(define-compiler-macro constantly (&whole form value-form &environment env) (cond - ((movitz:movitz-constantp value-form) - (let ((value (movitz:movitz-eval value-form))) - `(make-prototyped-function (constantly ,value) - constantly-prototype - (value ,value)))) + ((movitz:movitz-constantp value-form env) + (let ((value (movitz:movitz-eval value-form env))) + (case (translate-program value :muerte.cl :cl) + ((t) `(function constantly-true)) + ((nil) `(function constantly-false)) + (t `(make-prototyped-function (constantly ,value) + constantly-prototype + (value ,value)))))) (t (error "Non-constant constantly forms not yet supported: ~S" form) form))) @@ -64,7 +75,7 @@ (not (apply function args)))) (defun unbound-function (&edx edx &rest args) - (declare (dynamic-extent args) (ignore args)) + (declare (ignore args)) (let ((function-name (typecase edx (symbol edx) From ffjeld at common-lisp.net Sat Apr 24 15:13:27 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 24 Apr 2004 11:13:27 -0400 Subject: [movitz-cvs] CVS update: movitz/losp/tmp/harddisk.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/tmp In directory common-lisp.net:/tmp/cvs-serv21555 Modified Files: harddisk.lisp Log Message: Checked in new version from Peter Minten. Date: Sat Apr 24 11:13:27 2004 Author: ffjeld Index: movitz/losp/tmp/harddisk.lisp diff -u movitz/losp/tmp/harddisk.lisp:1.1 movitz/losp/tmp/harddisk.lisp:1.2 --- movitz/losp/tmp/harddisk.lisp:1.1 Mon Apr 19 18:55:55 2004 +++ movitz/losp/tmp/harddisk.lisp Sat Apr 24 11:13:26 2004 @@ -1,10 +1,23 @@ -;;;; $Id: harddisk.lisp,v 1.1 2004/04/19 22:55:55 ffjeld Exp $ +;;;; $Id: harddisk.lisp,v 1.2 2004/04/24 15:13:26 ffjeld Exp $ (require :lib/named-integers) +(provide :tmp/harddisk) -(provide :x86-pc/harddisk) +(defpackage muerte.x86-pc.harddisk + (:use muerte.cl muerte muerte.lib muerte.x86-pc) + (:export make-512-vector + hd-read-sectors + hd-write-sectors + hd-commands + )) -(in-package muerte.x86-pc) +(in-package muerte.x86-pc.harddisk) + +;;; +;;; global variables +;;; +(defvar *hd-controllers* (vector (make-instance 'hd-controller)) + "A vector of harddisk controllers.") ;;; ;;; constants @@ -16,53 +29,8 @@ (defconstant +hd-default-first-control-base+ #x3F6) (defconstant +hd-default-second-control-base+ #x376) -;;; -;;; structures -;;; - -(defstruct hd-controller - (number 0 :type integer) ;for error messages - (command-base +hd-default-first-command-base+ :type (integer 0 *)) - (control-base +hd-default-first-control-base+ :type (integer 0 *)) - (active-hd 0 :type hd) ;hd with pending task - (master nil :type hd) - (slave nil :type hd)) - -(defstruct hd - ;; hd info - (place 0 :type bit) ;0=master,1=slave - (cylinders 0 :type (integer 0 *)) - (heads 0 :type (integer 0 *)) - (spt 0 :type (integer 0 *)) - (sector-1-lba 0 :type (integer 0 *)) - ;; task stuff - (tasks (make-hash-table) :type hash-table) - (pending-tasks '() :type list) - (pending-last-cons '() :type cons) ;speeds append up - (active-task nil :type hd-task) - (done-tasks '() :type list)) - -(deftype hd-data-vector () - '(vector (unsigned-byte 8))) - -(defstruct hd-read-sectors-task - (start-sector 0 :type (unsigned-byte 28)) - (count 1 :type (integer 1 256)) - (data #() :type data-vector) - (offset 0 :type (integer 0 *))) - -(defstruct hd-write-sectors-task - (start-sector 0 :type (unsigned-byte 28)) - (count 1 :type (integer 1 256)) - (data #() :type data-vector) - (offset 0 :type (integer 0 *))) - -;;; -;;; low level code -;;; - (define-named-integer hd-register-offset - (:only-constants t :export-constants t) + (:only-constants t) (0 data) (1 error) (1 features) @@ -75,16 +43,12 @@ (7 command)) (define-named-integer hd-commands - (:only-constants t :export-constants t) + (:only-constants t) (#x20 read-sectors-with-retry) (#x30 write-sectors-with-retry)) -(defun hd-controller-command-register (hdc name type) - (+ (named-integer 'hd-register-offset name) - (hd-controller-command-base hdc))) - (define-named-integer hd-status-bits - (:only-constants t :export-constants t) + (:only-constants t) (0 error) (1 index) (2 corrected-data) @@ -94,130 +58,49 @@ (6 drive-ready) (7 busy)) -(defun hd-controller-busy (hdc) - ;; use control base, not command base, to avoid side effects - (/= 0 (logand (io-port (hd-controller-control-base hdc) - :unsigned-byte8) - #x80))) - -(defun hd-controller-wait-for-ready (hdc) ;wait for BSY=0 - (do () ((not (hd-controller-busy))) ())) - -(defun hd-controller-status (hdc code) - (named-integer 'hd-status-bits code)) - -(defmacro define-hd-controller-interrupt-handler (hdc irq) - (let ((name (gensym "hdc-irq-handler-"))) - `(progn - (defun ,name (number int-frame) - (declare (ignore (number int-frame))) - (let ((hdc ,hdc)) - (if (hd-controller-handle-task-signal hdc) - (hd-controller-queue-next-task hdc)))) - (setf (interrupt-handler ,irq) ,name)))) - -(defgeneric hd-controller-handle-task-signal (hdc task)) - -(defmethod hd-controller-handle-task-signal :before (hdc task) - (hd-controller-wait-for-ready hdc)) ;just in case - -(defmethod hd-controller-handle-task-signal (hdc (task hd-read-sectors-task)) - (with-slots (count data offset) task - (let ((status (io-port (hd-controller-command-register hdc 'status) - :unsigned-byte8)) - (read-data (io-port (hd-controller-command-register hdc 'status) - :unsigned-byte16))) - ;; by now the drive is getting the next piece, if necessary, - ;; so I hope this code is reentrant - (if (= 0 (logand (power 2 (hd-controller-status 'error)) - status)) - (progn - ;; read 512 bytes - (dotimes (i 256) - (setf (aref data offset) (logand read-data #xFF)) - (setf (aref data (1+ offset)) (logand read-data #xFF00)) - (incf offset 2)) - (= offset (1- (* count 512)))) ;return value, are we done or not? - (error "Harddrive read-sectors returned error. Controller nr ~A, HD number: -~A, error register: ~A." - (hd-controller-number hdc) - (hd-controller-active-hd hdc) - (io-port (hd-controller-command-register hdc 'error) - :unsigned-byte8)))))) - -(defmethod hd-controller-handle-task-signal (hdc (task hd-write-sectors-task)) - (with-slots (count data offset) task - (let ((status (io-port (hd-controller-command-register hdc 'status) - :unsigned-byte8)) - (write-data nil)) - (if (= 0 (logand (power 2 (hd-controller-status 'error)) - status)) - (if (= 0 (logand (power 2 (hd-controller-status 'data-request)) - status)) - ;; write 512 bytes - (progn - (dotimes (i 256) - ;; hope the byte order is correct - (setf write-data (aref data offset)) - (incf write-data (* #xFF (aref data (1+ offset)))) - (incf offset 2) - (setf (io-port (hd-controller-command-register hdc 'data) - :unsigned-byte16) - write-data)) - nil) ;not done yet - t) ;no data requested, so done - (error "Harddrive read-sectors returned error. Controller nr ~A, HD number: -~A, error register: ~A." - (hd-controller-number hdc) - (hd-controller-active-hd hdc) - (io-port (hd-controller-command-register hdc 'error) - :unsigned-byte8)))))) - - -(defmethod hd-controller-feed-task :before (hdc task) - (hd-controller-wait-for-ready hdc) - ;; we always use LBA mode +;;; +;;; classes +;;; +(defclass hd-controller () + ((command-base :initform +hd-default-first-command-base+ + :initarg :command-base + :type integer) + (control-base :initform +hd-default-first-control-base+ + :initarg :command-base + :type integer))) + +;;; +;;; waiters +;;; +(defun hd-controller-wait-for-drive-ready (hdc) ;wait for DRDY=1 + (with-slots (control-base) hdc + (loop until (/= 0 (logand (io-port control-base :unsigned-byte8) + #x40))))) + +(defun hd-controller-wait-for-ready (hdc) ;wait for BSY=0 + (with-slots (control-base) hdc + (loop until (= 0 (logand (io-port control-base :unsigned-byte8) + #x80))))) + +(defun hd-controller-wait-for-data-request (hdc) ;wait for DRQ=1 + (with-slots (control-base) hdc + (loop until (/= 0 (logand (io-port control-base :unsigned-byte8) + #x08))))) + +;;; +;;; feeders +;;; +(defun hd-controller-feed-lba-mode (hdc) (setf (io-port (hd-controller-command-register hdc 'lba-byte-4) :unsigned-byte8) (logior (io-port (hd-controller-command-register hdc 'lba-byte-4) :unsigned-byte8) #b01000000))) -(defmethod hd-controller-feed-task (hdc (task hd-read-sectors-task)) - (with-slots (drive count start-sector) task - ;; set drive - (hd-controller-feed-drive hdc drive) - ;; set count - (setf (io-port (hd-controller-command-register hdc 'sector-count) - :unsigned-byte8) - count) - ;; set address - (hd-controller-feed-lba-address start-sector) - ;; get going - (setf (io-port (hd-controller-command-register hdc 'command) - :unsigned-byte8) - (named-integer 'hd-commands 'read-sectors-with-retry)))) - -(defmethod hd-controller-feed-task (hdc (task hd-write-sectors-task)) - (with-slots (count start-sector offset data) task - ;; set drive - (hd-controller-feed-drive hdc) - ;; set count - (setf (io-port (hd-controller-command-register hdc 'sector-count) - :unsigned-byte8) - count) - ;; set address - (hd-controller-feed-lba-address start-sector) - ;; get going - (setf (io-port (hd-controller-command-register hdc 'command) - :unsigned-byte8) - (named-integer 'hd-commands 'read-sectors-with-retry)))) - - -(defun hd-controller-feed-drive (hdc) +(defun hd-controller-feed-drive (hdc drive) (setf (io-port (hd-controller-command-register hdc 'lba-byte-4) :unsigned-byte8) - (logior (* #b00010000 (hd-controller-active-hd hdc)) + (logior (* #b00010000 drive) (logand (io-port (hd-controller-command-register hdc 'lba-byte-4) :unsigned-byte8) #b11101111)))) @@ -239,43 +122,143 @@ (logand lba #x000F0000)))) ;;; -;;; scheduler code +;;; misc +;;; +(defmacro while (test &body body) + `(do () ((not ,test)) + , at body)) + +(defun div (a b) + "Floored integer division, the painful way." + (let ((r 0) + (x a)) + (while (>= x 0) + (decf x b) + (incf r)) + (1- r))) + +(defun log2 (n) + (cond ((= n 256) 8) + ((= n 128) 7) + ((= n 64) 6) + ((= n 32) 5) + ((= n 16) 4) + ((= n 8) 3) + ((= n 4) 2) + ((= n 2) 1) + ((= n 1) 0))) + +(defmacro with-hd-info ((hdc drive-number) hd-number &body body) + (let ((gs-hdnr (gensym "hd-number-"))) + `(let* ((,gs-hdnr ,hd-number) + (,hdc (aref *hd-controllers* (div ,hd-number 2))) + (,drive-number (mod ,gs-hdnr 2))) + , at body))) + +(defun hd-controller-command-register (hdc name) + ;; use a case statement for now, until I learn how to use + ;; named-integer right + (+ (case name + ('data 0) + ('error 1) + ('features 1) + ('sector-count 2) + ('lba-byte-1 3) + ('lba-byte-2 4) + ('lba-byte-3 5) + ('lba-byte-4 6) + ('status 7) + ('command 7) + (else (error "HD command register not found ~A" name))) + (slot-value hdc 'command-base))) + +(defun error-code-meaning (code) + (nth (log2 code) + '("Address Mark Not Found" + "Track 0 Not Found" + "Media Change Requested" + "Aborted Command" + "ID Not Found" + "Media Changed" + "Uncorrectable Data Error" + "Bad Block Detected"))) + + +(defun hd-check-error (hdc command-name hdnr) + "Check and when found signal an error in task." + (when (/= 0 (logand (io-port (slot-value hdc 'control-base) + :unsigned-byte8) + #x01)) + (error "Harddrive command ~A returned error. HD number: ~A. Error message: '~A'." + command-name hdnr + (error-code-meaning + (io-port (hd-controller-command-register hdc 'error) + :unsigned-byte8))))) + +;;; +;;; hd operations ;;; -(defun hd-queue-next-task (hdc) - ;; very dumb scheduler, FIFO and master before slave - (labels ((queue (hd) - (let ((task (first (hd-pending-tasks hd)))) - (setf (hd-active-task hd) task) - (unless (rest (hd-pending-tasks hd)) - (setf (hd-pending-last-cons hd) - (hd-pending-tasks hd))) - (hd-controller-feed-task hdc task)))) - (let ((master (hd-controller-master hdc)) - (slave (hd-controller-slave hdc))) - (cond ((> 0 (length (hd-pending-tasks master))) - (queue master) - (setf (hd-controller-active-hd hdc) 0)) - ((> 0 (length (hd-pending-tasks slave))) - (queue slave) - (setf (hd-controller-active-hd hdc) 1)))))) - - -(defun hd-add-read-sectors-task (hd start-sector count) - "Add a task to read count sectors, starting at start-sector. Count -must be between 1 and 256 inclusive." - (let* ((task (make-hd-read-sectors-task :start-sector start-sector - :count (mod (count 256)))) - - (pending-cons (cons task nil))) - (rplacd (hd-pending-last-cons hd) pending-cons) - (setf (hd-pending-last-cons hd) pending-cons))) - -(defun hd-add-write-sectors-task (hd start-sector count data) - "Add a task to write count sectors of data, starting at -start-sector. Count must be between 1 and 256 inclusive." - (let* ((task (make-hd-read-sectors-task :start-sector start-sector - :count (mod (count 256)) - :data data)) - (pending-cons (cons task nil))) - (rplacd (hd-pending-last-cons hd) pending-cons) - (setf (hd-pending-last-cons hd) pending-cons))) \ No newline at end of file +(defun hd-read-sectors (hdnr start-sector count) + (let ((data (make-array 512 :element-type :unsigned-byte8)) + (offset 0) + (read-data nil)) + (with-hd-info (hdc drive) hdnr + ;; set drive + (hd-controller-feed-drive hdc drive) + ;; set count + (setf (io-port (hd-controller-command-register hdc 'sector-count) + :unsigned-byte8) + count) + ;; set LBA and address + (hd-controller-feed-lba-mode hdc) + (hd-controller-feed-lba-address hdc start-sector) + ;; get going + (setf (io-port (hd-controller-command-register hdc 'command) + :unsigned-byte8) + +hd-commands-read-sectors-with-retry+) + ;; data handling + (while (<= offset (* count 512)) + (hd-controller-wait-for-drive-ready hdc) + (hd-controller-wait-for-ready hdc) + (hd-check-error hdc "read-sectors" hdnr) + (hd-controller-wait-for-data-request hdc) + (dotimes (i 256) + (setf read-data (io-port (hd-controller-command-register hdc 'status) + :unsigned-byte16))) + (setf (aref data offset) (logand read-data #xFF)) + (setf (aref data (1+ offset)) (logand read-data #xFF00)) + (incf offset 2)) + ;; done + data))) + +(defun hd-write-sectors (hdnr start-sector data) + (let ((offset 0) + (write-data nil) + (count (div (length data) 512))) + (with-hd-info (hdc drive) hdnr + ;; set drive + (hd-controller-feed-drive hdc drive) + ;; set count + (setf (io-port (hd-controller-command-register hdc 'sector-count) + :unsigned-byte8) + count) + ;; set LBA and address + (hd-controller-feed-lba-mode hdc) + (hd-controller-feed-lba-address hdc start-sector) + ;; get going + (setf (io-port (hd-controller-command-register hdc 'command) + :unsigned-byte8) + +hd-commands-write-sectors-with-retry+) + ;; data handling + (while (<= offset (* count 512)) + (hd-controller-wait-for-drive-ready hdc) + (hd-controller-wait-for-ready hdc) + (hd-check-error hdc "write-sectors" hdnr) + (hd-controller-wait-for-data-request hdc) + (dotimes (i 256) + (setf write-data (aref data offset)) + (incf write-data (* #xFF (aref data (1+ offset)))) + (setf (io-port (hd-controller-command-register hdc 'data) + :unsigned-byte16) + write-data) + (incf offset 2)))))) \ No newline at end of file