April 2007 - movitz-cvs@common-lisp.net - mailman3.common-lisp.net

[movitz-cvs] CVS movitz/losp/x86-pc
by ffjeld 28 Apr '07

28 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv23233 Added Files: pcnet.lisp Log Message: The beginnings of a pcnet driver. --- /project/movitz/cvsroot/movitz/losp/x86-pc/pcnet.lisp 2007/04/28 16:29:18 NONE +++ /project/movitz/cvsroot/movitz/losp/x86-pc/pcnet.lisp 2007/04/28 16:29:18 1.1 ;;;;------------------------------------------------------------------ ;;;; ;;;; Copyright (C) 2003, 2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. ;;;; ;;;; Filename: pcnet.lisp ;;;; Description: ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Aug 12 23:39:20 2005 ;;;; ;;;; $Id: pcnet.lisp,v 1.1 2007/04/28 16:29:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (provide :x86-pc/pcnet) (in-package muerte.x86-pc) (defmacro select (keyform &rest clauses) (let* ((select-var (gensym "select-key-")) (cc (loop for (key . consequents) in clauses collecting (cond ((member key '(t otherwise)) (cons t consequents)) (t (cons `(eql ,key ,select-var) consequents)))))) `(let ((,select-var ,keyform)) (cond ,@cc)))) (defmacro $am7990 (reg &optional sub-reg) (or (cond ((integerp reg) reg) ((not sub-reg) (case reg (:csr0 0) (:csr1 1) (:csr2 2) (:csr3 3) (:csr88 88) (:csr89 89) (:bcr49 49) (:bcr32 32) (:bcr33 33) (bcr34 34))) (t (if (integerp sub-reg) sub-reg (case reg (:csr0 (case sub-reg (:err #x8000) (:babl #x4000) (:cerr #x2000) (:miss #x1000) (:merr #x0800) (:rint #x0400) (:tint #x0200) (:idon #x0100) (:intr #x0080) (:inea #x0040) (:rxon #x0020) (:txon #x0010) (:tdmd #x0008) (:stop #x0004) (:strt #x0002) (:init #x0001))) (:csr88 (case sub-reg (:AMD-MASK #x003) (:PART-MASK #xffff) (:|Am79C960| #x0003) (:|Am79C961| #x2260) (:|Am79C961A| #x2261) (:|Am79C965| #x2430) (:|Am79C970| #x0242) (:|Am79C970A| #x2621) (:|Am79C971| #x2623) (:|Am79C972| #x2624) (:|Am79C973| #x2625) (:|Am79C978| #x2626) )))))) (error "Unknown Am7990 register: ~S~@[ ~S~]" reg sub-reg))) (defmacro $pcnet (reg) "PCNet is one Am7990 implementation." (or (cond ((integerp reg) reg) (t (case reg (:rdp #x10) (:rap #x12) (:reset #x14) (:bdp #x16) (:vsw #x18)))) `($am7990 ,reg))) (defmacro with-am7990 ((name io-base regdef) &body body) (let ((pcnet-io (gensym "pcnet-io-"))) `(with-io-register-syntax (,pcnet-io ,io-base) (macrolet ((,name (op &optional reg) (ecase op (:rdp `(,',pcnet-io (,',regdef :rdp) :unsigned-byte16)) (:csr `(,',pcnet-io (progn (setf (,',pcnet-io (,',regdef :rap) :unsigned-byte16) (,',regdef ,reg)) (,',regdef :rdp)) :unsigned-byte16)) ))) ,@body)))) (defmacro with-am7990-ports ((name rap rdp bdp) &body body) `(macrolet ((,name (reg) (case reg (:rap ',rap) (:rdp ',rdp) (:bdp ',bdp) (t `($am7990 ,reg))))) ,@body)) (defun lance-probe (io-base rap rdp bdp) (declare (ignorable bdp)) (with-am7990-ports ($lance rap rdp bdp) (with-am7990 (pcnet io-base $lance) (setf (pcnet :csr :csr0) ($am7990 :csr0 :stop)) (when (and (/= 0 (logand (pcnet :rdp) ($am7990 :csr0 :stop))) (= 0 (pcnet :csr :csr3))) (setf (pcnet :csr :csr0) ($am7990 :csr0 :inea)) (if (/= 0 (logand (pcnet :csr :csr0) ($am7990 :csr0 :inea))) 'c-lance 'lance))))) (defun am7990-probe (io-base rap rdp bdp) (let ((type (lance-probe io-base rap rdp bdp))) (when type (with-am7990-ports ($ports rap rdp bdp) (with-am7990 (pcnet io-base $ports) (let ((chip-id (dpb (pcnet :csr :csr89) (byte 16 16) (pcnet :csr :csr88)))) (when (/= 0 (logand chip-id ($am7990 :csr88 :amd-mask))) (select (ldb (byte 16 12) chip-id) (($am7990 :csr88 :|Am79C960|) 'PCnet-ISA) (($am7990 :csr88 :|Am79C961|) 'PCnet-ISAplus) (($am7990 :csr88 :|Am79C961A|) 'PCnet-ISA-II) (($am7990 :csr88 :|Am79C965|) (values 'PCnet-32 t)) (($am7990 :csr88 :|Am79C970|) (vaues 'PCnet-PCI t)) (($am7990 :csr88 :|Am79C970A|) (values 'PCnet-PCI-II t)) (($am7990 :csr88 :|Am79C971|) (values 'PCnet-FAST t)) (($am7990 :csr88 :|Am79C972|) (values 'PCnet-FASTplus t)) (($am7990 :csr88 :|Am79C973|) (values 'PCnet-FASTplus t)) (($am7990 :csr88 :|Am79C978|) (values 'PCnet-Home t)) (t type))))))))) (defclass ne2100-pci (muerte.ethernet:ethernet-device) ()) (defun pcnet-probe-pci () (multiple-value-bind (bus device function) (find-pci-device #x1022 #x2000) (apply #'attach-ne2100-pci (pci-device-address-maps bus device function)))) (defun attach-ne2100-pci (&key io &allow-other-keys) (check-type io (unsigned-byte 16) "an I/O port") (multiple-value-bind (ic 32bit-p) (am7990-probe io ($pcnet :rap) ($pcnet :rdp) ($pcnet :bdp)) (when 32bit-p (make-instance 'ne2100-pci :mac-address (coerce (loop for i from 0 below 6 collect (io-port (+ io i) :unsigned-byte8)) 'muerte.ethernet:mac-address)))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 13 Apr '07

13 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv14541 Modified Files: setf.lisp Log Message: Add (a hackish) support for (setf the). --- /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp 2007/03/02 22:01:33 1.5 +++ /project/movitz/cvsroot/movitz/losp/muerte/setf.lisp 2007/04/13 23:29:31 1.6 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu Feb 8 20:43:20 2001 ;;;; -;;;; $Id: setf.lisp,v 1.5 2007/03/02 22:01:33 ffjeld Exp $ +;;;; $Id: setf.lisp,v 1.6 2007/04/13 23:29:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -33,32 +33,32 @@ (expander (and name (movitz::movitz-env-get name 'setf-expander nil environment)))) (if expander (funcall expander place environment) - (multiple-value-bind (expansion expanded-p) - (movitz::movitz-macroexpand-1 place environment) - (cond - (expanded-p - (when (eq expansion place) - (warn "exp place are eq! ~S" place)) - (get-setf-expansion expansion environment)) - ((symbolp place) - (let ((store-var (gensym "store-var-"))) - (values nil nil (list store-var) `(setq ,place ,store-var) place))) - ((assert (consp place))) - (t (multiple-value-bind (tmp-vars tmp-var-init-forms arglist) - (loop for sub-form in (cdr place) - as tmp-var = (gensym "tmp-var-") - if (movitz:movitz-constantp sub-form environment) - collect sub-form into arglist - else collect tmp-var into tmp-vars - and collect sub-form into tmp-var-init-forms - and collect tmp-var into arglist - finally (return (values tmp-vars tmp-var-init-forms arglist))) - (let ((store-var (gensym "store-var-"))) - (values tmp-vars - tmp-var-init-forms - (list store-var) - `(funcall #'(setf ,(car place)) ,store-var ,@arglist) - (list* (car place) arglist))))))))))) + (multiple-value-bind (expansion expanded-p) + (movitz::movitz-macroexpand-1 place environment) + (cond + (expanded-p + (when (eq expansion place) + (warn "exp place are eq! ~S" place)) + (get-setf-expansion expansion environment)) + ((symbolp place) + (let ((store-var (gensym "store-var-"))) + (values nil nil (list store-var) `(setq ,place ,store-var) place))) + ((assert (consp place))) + (t (multiple-value-bind (tmp-vars tmp-var-init-forms arglist) + (loop for sub-form in (cdr place) + as tmp-var = (gensym "tmp-var-") + if (movitz:movitz-constantp sub-form environment) + collect sub-form into arglist + else collect tmp-var into tmp-vars + and collect sub-form into tmp-var-init-forms + and collect tmp-var into arglist + finally (return (values tmp-vars tmp-var-init-forms arglist))) + (let ((store-var (gensym "store-var-"))) + (values tmp-vars + tmp-var-init-forms + (list store-var) + `(funcall #'(setf ,(car place)) ,store-var ,@arglist) + (list* (car place) arglist))))))))))) ;;;(defsetf subseq (sequence start &optional end) (new-sequence) @@ -87,53 +87,53 @@ (defmacro defsetf (access-fn &rest more-args) (cond - ((symbolp (first more-args)) - ;; short form XXX not really good. - `(defun (setf ,access-fn) (fu foo) - (,(first more-args) fu foo))) - (t ;; long form - (destructuring-bind (lambda-list store-variables &body body-decl-docstring) - more-args - (multiple-value-bind (body declarations docstring) - (movitz::parse-docstring-declarations-and-body body-decl-docstring 'cl:declare) - (let ((movitz-lambda (movitz::translate-program lambda-list :cl :muerte.cl))) - (multiple-value-bind (wholevars envvars reqvars optionalvars restvar keys auxes) - (movitz::decode-macro-lambda-list movitz-lambda) - (assert (null restvar)) - (assert (null envvars)) - (assert (null wholevars)) - (assert (null auxes)) - (assert (null keys)) - (let* ((req-tmps (mapcar (lambda (x) (list x (gensym))) - reqvars)) - (opt-vars (mapcar #'movitz::decode-optional-formal - optionalvars)) - (opt-tmps (mapcar (lambda (x) (list x (gensym))) - opt-vars)) - (tmp-lets (append (mapcar (lambda (rt) - (list (second rt) '(gensym))) - req-tmps) - (mapcar (lambda (rt) - (list (second rt) '(gensym))) - opt-tmps) - `((init-form (list ,@reqvars ,@opt-vars))) - (mapcar (lambda (rt) - (list rt '(gensym))) - store-variables))) - (lambda-lets (append req-tmps opt-tmps))) - `(define-setf-expander ,access-fn ,movitz-lambda - (declare ,@declarations) - ,@(when docstring (list docstring)) - (let ,tmp-lets - (let ,lambda-lets - (values (list ,@(mapcar #'second req-tmps) - ,@(mapcar #'second opt-tmps)) - init-form - (list ,@store-variables) - (progn ,@body) - (list ',access-fn - ,@(mapcar #'first req-tmps) - ,@(mapcar #'first opt-tmps)))))))))))))) + ((symbolp (first more-args)) + ;; short form XXX not really good. + `(defun (setf ,access-fn) (fu foo) + (,(first more-args) fu foo))) + (t ;; long form + (destructuring-bind (lambda-list store-variables &body body-decl-docstring) + more-args + (multiple-value-bind (body declarations docstring) + (movitz::parse-docstring-declarations-and-body body-decl-docstring 'cl:declare) + (let ((movitz-lambda (movitz::translate-program lambda-list :cl :muerte.cl))) + (multiple-value-bind (wholevars envvars reqvars optionalvars restvar keys auxes) + (movitz::decode-macro-lambda-list movitz-lambda) + (assert (null restvar)) + (assert (null envvars)) + (assert (null wholevars)) + (assert (null auxes)) + (assert (null keys)) + (let* ((req-tmps (mapcar (lambda (x) (list x (gensym))) + reqvars)) + (opt-vars (mapcar #'movitz::decode-optional-formal + optionalvars)) + (opt-tmps (mapcar (lambda (x) (list x (gensym))) + opt-vars)) + (tmp-lets (append (mapcar (lambda (rt) + (list (second rt) '(gensym))) + req-tmps) + (mapcar (lambda (rt) + (list (second rt) '(gensym))) + opt-tmps) + `((init-form (list ,@reqvars ,@opt-vars))) + (mapcar (lambda (rt) + (list rt '(gensym))) + store-variables))) + (lambda-lets (append req-tmps opt-tmps))) + `(define-setf-expander ,access-fn ,movitz-lambda + (declare ,@declarations) + ,@(when docstring (list docstring)) + (let ,tmp-lets + (let ,lambda-lets + (values (list ,@(mapcar #'second req-tmps) + ,@(mapcar #'second opt-tmps)) + init-form + (list ,@store-variables) + (progn ,@body) + (list ',access-fn + ,@(mapcar #'first req-tmps) + ,@(mapcar #'first opt-tmps)))))))))))))) (defmacro define-modify-macro (name lambda-list function &optional documentation) @@ -147,8 +147,8 @@ (multiple-value-bind (tmp-vars tmp-var-init-forms store-vars setter-form getter-form) (get-setf-expansion place env) (assert (= 1 (length store-vars)) () - "Don't know how to modify a place with ~D cells." - (length store-vars)) + "Don't know how to modify a place with ~D cells." + (length store-vars)) `(let ,(mapcar #'list tmp-vars tmp-var-init-forms) ;; We love backquote.. (let ((,(first store-vars) (,',function @@ -163,36 +163,37 @@ (defmacro setf (&environment env &rest pairs) (let ((num-pairs (length pairs))) (cond - ((= 2 num-pairs) - (destructuring-bind (place new-value-form) - pairs - ;; 5.1.2 Kinds of Places - (cond - ((symbolp place) ; 5.1.2.1 Variable Names as Places - (multiple-value-bind (expansion expanded-p) - (movitz::movitz-macroexpand-1 place env) - (if expanded-p - `(setf ,expansion ,new-value-form) - `(setq ,place ,new-value-form)))) - (t (multiple-value-bind (tmp-vars tmp-forms store-vars setter-form) - (get-setf-expansion place env) - (case (length store-vars) - (0 `(progn ,@tmp-forms ,new-value-form nil)) - (1 `(let (,@(loop for tmp-var in tmp-vars - for tmp-form in tmp-forms - collect `(,tmp-var ,tmp-form)) - (,(first store-vars) ,new-value-form)) - (declare (ignorable ,@tmp-vars)) - ,setter-form)) - (t `(let ,(loop for tmp-var in tmp-vars - for tmp-form in tmp-forms - collect `(,tmp-var ,tmp-form)) - (multiple-value-bind ,store-vars - ,new-value-form - ,setter-form))))))))) - ((evenp num-pairs) - (cons 'progn - (loop for (place newvalue) on pairs by #'cddr - collect `(setf ,place ,newvalue)))) - (t (error "Odd number of arguments to SETF."))))) - + ((= 2 num-pairs) + (destructuring-bind (place new-value-form) + pairs + ;; 5.1.2 Kinds of Places + (typecase place + (symbol ; 5.1.2.1 Variable Names as Places + (multiple-value-bind (expansion expanded-p) + (movitz::movitz-macroexpand-1 place env) + (if expanded-p + `(setf ,expansion ,new-value-form) + `(setq ,place ,new-value-form)))) + ((cons (eql the)) + `(setf ,(third place) (the ,(second place) ,new-value-form))) + (t (multiple-value-bind (tmp-vars tmp-forms store-vars setter-form) + (get-setf-expansion place env) + (case (length store-vars) + (0 `(progn ,@tmp-forms ,new-value-form nil)) + (1 `(let (,@(loop for tmp-var in tmp-vars + for tmp-form in tmp-forms + collect `(,tmp-var ,tmp-form)) + (,(first store-vars) ,new-value-form)) + (declare (ignorable ,@tmp-vars)) + ,setter-form)) + (t `(let ,(loop for tmp-var in tmp-vars + for tmp-form in tmp-forms + collect `(,tmp-var ,tmp-form)) + (multiple-value-bind ,store-vars + ,new-value-form + ,setter-form))))))))) + ((evenp num-pairs) + (cons 'progn + (loop for (place newvalue) on pairs by #'cddr + collect `(setf ,place ,newvalue)))) + (t (error "Odd number of arguments to SETF.")))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 13 Apr '07

13 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv11775 Modified Files: memref.lisp Log Message: Improve (setf memref-int) somewhat. --- /project/movitz/cvsroot/movitz/losp/muerte/memref.lisp 2005/08/24 07:30:14 1.48 +++ /project/movitz/cvsroot/movitz/losp/muerte/memref.lisp 2007/04/13 23:19:57 1.49 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.48 2005/08/24 07:30:14 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.49 2007/04/13 23:19:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1043,19 +1043,22 @@ (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) (,prefixes :movl :eax (:ecx :ebx)))) (:unsigned-byte8 - `(with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :push) ,address) - (:compile-form (:result-mode :push) ,index) - (:compile-form (:result-mode :push) ,offset) - (:compile-form (:result-mode :eax) ,value) - (:popl :edx) ; offset - (:popl :ebx) ; index - (:popl :ecx) ; address - (:shll ,(- 8 movitz::+movitz-fixnum-shift+) :eax) - (:addl :ebx :ecx) - (:addl :edx :ecx) - (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) - (,prefixes :movb :ah (:ecx)))) + (let ((address-var (gensym "memref-int-address-")) + (index-var (gensym "memref-int-index-var-")) + (offset-var (gensym "memref-int-offset-var-")) + (value-var (gensym "memref-int-value-var-"))) + `(let ((,value-var ,value) + (,address-var ,address) + (,offset-var (+ ,index ,offset))) + (with-inline-assembly (:returns :nothing) + (:load-lexical (:lexical-binding ,address-var) :ecx) + (:load-lexical (:lexical-binding ,offset-var) :edx) + (:load-lexical (:lexical-binding ,value-var) :eax) + (:shll ,(- 8 movitz::+movitz-fixnum-shift+) :eax) + (:addl :edx :ecx) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) + (,prefixes :movb :ah (:ecx))) + ,value-var))) (:unsigned-byte16 (cond ((eq 0 offset) @@ -1102,22 +1105,28 @@ (defun (setf memref-int) (value address &key (offset 0) (index 0) (type :unsigned-byte32) (physicalp t)) (cond - (physicalp - (ecase type - (:unsigned-byte8 - (setf (memref-int address :offset offset :index index :type :unsigned-byte8) - value)) - (:unsigned-byte16 - (setf (memref-int address :offset offset :index index :type :unsigned-byte16) - value)))) - ((not physicalp) - (ecase type - (:unsigned-byte8 - (setf (memref-int address :offset offset :index index :type :unsigned-byte8 :physicalp nil) - value)) - (:unsigned-byte16 - (setf (memref-int address :offset offset :index index :type :unsigned-byte16 :physicalp nil) - value)))))) + (physicalp + (ecase type + (:unsigned-byte8 + (setf (memref-int address :offset offset :index index :type :unsigned-byte8) + value)) + (:unsigned-byte16 + (setf (memref-int address :offset offset :index index :type :unsigned-byte16) + value)) + (:unsigned-byte32 + (setf (memref-int address :offset offset :index index :type :unsigned-byte32) + value)))) + ((not physicalp) + (ecase type + (:unsigned-byte8 + (setf (memref-int address :offset offset :index index :type :unsigned-byte8 :physicalp nil) + value)) + (:unsigned-byte16 + (setf (memref-int address :offset offset :index index :type :unsigned-byte16 :physicalp nil) + value)) + (:unsigned-byte32 + (setf (memref-int address :offset offset :index index :type :unsigned-byte32 :physicalp nil) + value)))))) (defun memcopy (object-1 object-2 offset index-1 index-2 count type) (ecase type

1 0

[movitz-cvs] CVS movitz/losp/x86-pc
by ffjeld 13 Apr '07

13 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv7718 Modified Files: vga.lisp Log Message: Tweaked (setf pixel). --- /project/movitz/cvsroot/movitz/losp/x86-pc/vga.lisp 2007/04/07 08:04:51 1.13 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/vga.lisp 2007/04/13 22:59:26 1.14 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 25 14:08:20 2001 ;;;; -;;;; $Id: vga.lisp,v 1.13 2007/04/07 08:04:51 ffjeld Exp $ +;;;; $Id: vga.lisp,v 1.14 2007/04/13 22:59:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1131,20 +1131,23 @@ ;; set a pixel to a colour of our choice ;; write to the NEXT page -(defun (setf pixel) (col x y) - (cond ((< x (nth 0 (viewport))) (return-from pixel nil)) - ((> x (nth 1 (viewport))) (return-from pixel nil)) - ((< y (nth 2 (viewport))) (return-from pixel nil)) - ((> y (nth 3 (viewport))) (return-from pixel nil)) - (t (set-plane (logand x 3)) - (setf (memref-int (vga-memory-map) - :index (+ (* (truncate *vga-width* 4) y) ; pixel - (truncate x 4) - (* (truncate *vga-width* 2) ; page - *vga-height* - *vga-current-page*)) - :type :unsigned-byte8) - col)))) +(defun (setf pixel) (color x y) + (cond + ((< x (nth 0 (viewport)))) + ((>= x (nth 1 (viewport)))) + ((< y (nth 2 (viewport)))) + ((>= y (nth 3 (viewport)))) + (t (set-plane (logand x 3)) + (setf (memref-int (vga-memory-map) + :index (+ (* (truncate *vga-width* 4) y) ; pixel + (truncate x 4) + (* (truncate *vga-width* 2) ; page + *vga-height* + *vga-current-page*)) + :type :unsigned-byte8) + color))) + color) + ; return the current viewport as a list

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 13 Apr '07

13 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv4950 Modified Files: segments.lisp Log Message: In (setf segment-descriptor-limit), prefer (setf ldb) over logior etc. --- /project/movitz/cvsroot/movitz/losp/muerte/segments.lisp 2007/04/13 22:37:04 1.18 +++ /project/movitz/cvsroot/movitz/losp/muerte/segments.lisp 2007/04/13 22:41:05 1.19 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu May 8 14:25:06 2003 ;;;; -;;;; $Id: segments.lisp,v 1.18 2007/04/13 22:37:04 ffjeld Exp $ +;;;; $Id: segments.lisp,v 1.19 2007/04/13 22:41:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -228,9 +228,8 @@ (check-type table (and vector (not simple-vector))) (let ((offset (+ (logand #xfff8 selector) (movitz-type-slot-offset 'movitz-basic-vector 'data)))) - (setf (memref table (+ 6 offset) :type :unsigned-byte8) - (logior (ldb (byte 4 16) limit) - (ash (segment-descriptor-avl-x-db-g table selector) 4))) + (setf (ldb (byte 4 0) (memref table (+ 6 offset) :type :unsigned-byte8)) + (ldb (byte 4 16) limit)) (setf (memref table (+ 0 offset) :type :unsigned-byte16) (ldb (byte 16 0) limit)) limit))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 13 Apr '07

13 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv2950 Modified Files: segments.lisp Log Message: Fix (setf segment-descriptor-limit). Patch from Paavo. --- /project/movitz/cvsroot/movitz/losp/muerte/segments.lisp 2007/03/21 20:20:12 1.17 +++ /project/movitz/cvsroot/movitz/losp/muerte/segments.lisp 2007/04/13 22:37:04 1.18 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Thu May 8 14:25:06 2003 ;;;; -;;;; $Id: segments.lisp,v 1.17 2007/03/21 20:20:12 ffjeld Exp $ +;;;; $Id: segments.lisp,v 1.18 2007/04/13 22:37:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -229,9 +229,10 @@ (let ((offset (+ (logand #xfff8 selector) (movitz-type-slot-offset 'movitz-basic-vector 'data)))) (setf (memref table (+ 6 offset) :type :unsigned-byte8) - (ldb (byte 4 16) limit)) - (setf (memref table (+ 0 offset) :type :unsigned-byte8) - (ldb (byte 16 0) limit)) + (logior (ldb (byte 4 16) limit) + (ash (segment-descriptor-avl-x-db-g table selector) 4))) + (setf (memref table (+ 0 offset) :type :unsigned-byte16) + (ldb (byte 16 0) limit)) limit)) (defun segment-descriptor-type-s-dpl-p (table selector)

1 0

[movitz-cvs] CVS movitz/losp/x86-pc
by ffjeld 12 Apr '07

12 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv9942 Modified Files: debugger.lisp Log Message: Remove dead code. --- /project/movitz/cvsroot/movitz/losp/x86-pc/debugger.lisp 2006/03/21 20:13:12 1.42 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/debugger.lisp 2007/04/12 16:11:15 1.43 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.42 2006/03/21 20:13:12 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.43 2007/04/12 16:11:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -53,7 +53,7 @@ (defvar *backtrace-stack-frame-barrier* nil) (defvar *backtrace-do-fresh-lines* t) (defvar *backtrace-print-length* 3) -(defvar *backtrace-print-level* 2) +(defvar *backtrace-print-level* 3) (defvar *backtrace-print-frames* nil) (defun pointer-in-range (x) @@ -72,31 +72,6 @@ (when (<= 0 delta (length code-vector)) delta)))) - -#+ignore -(defun print-dynamic-context (&key terse symbol) - (loop for dynamic-context = (current-dynamic-context) - then (dynamic-context-uplink dynamic-context) - while (stack-ref-p dynamic-context) - do (let ((tag (dynamic-context-tag dynamic-context))) - (cond - ((eq tag (load-global-constant unbound-value)) - (let ((name (stack-ref dynamic-context 0 0 :lisp))) - (when (or (not symbol) (eq symbol name)) - (format t (if terse - "| #x~X: n: ~S, v: ~Z. |" - "~&#x~X: name: ~A~% value: ~A") - dynamic-context name - (stack-ref dynamic-context 8 0 :lisp))))) - ((not symbol) - (format t (if terse - "| #x~X: t: ~Z. |" - "~&#x~X: tag: ~S") - dynamic-context - tag)))) - finally (format t "~&Last uplink: #x~X~%" dynamic-context) - (return (values)))) - (defun funobj-name-or-nil (x) (typecase x (compiled-function

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 12 Apr '07

12 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv9876 Modified Files: inspect.lisp Log Message: Improve print-dynamic-context & friends. --- /project/movitz/cvsroot/movitz/losp/muerte/inspect.lisp 2007/04/07 08:01:41 1.59 +++ /project/movitz/cvsroot/movitz/losp/muerte/inspect.lisp 2007/04/12 16:10:47 1.60 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.59 2007/04/07 08:01:41 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.60 2007/04/12 16:10:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -38,6 +38,11 @@ (declare (without-check-stack-limit)) ; we do it explicitly.. (check-stack-limit)) +(defun protect-unbound (x) + (if (not (eq x (%run-time-context-slot nil 'new-unbound-value))) + x + (format nil "#<unbound #x~X>" (%object-lispval x)))) + (defun stack-frame-funobj (stack frame) (stack-frame-ref stack frame -1)) @@ -113,6 +118,13 @@ (defun dynamic-context-tag (dynamic-context) (stack-frame-ref nil dynamic-context 1 :lisp)) +(defun stack-index-frame (stack index start-frame) + "Find the frame in which index is included." + (do ((frame start-frame (stack-frame-uplink stack frame))) + ((eq 0 frame) nil) + (when (< index frame) + (return frame)))) + (defmacro with-each-dynamic-context ((&optional start-context result) &rest clauses) "Only use this if you know what you're doing. See run-time.lisp." (let ((context (gensym "dynamic-context-")) @@ -120,6 +132,7 @@ (name (gensym "dynamic-name-")) (bind-clause (find :binding clauses :key #'caar)) (catch-clause (find :catch clauses :key #'caar)) + (lcatch-clause (find :lexical-catch clauses :key #'caar)) (up-clause (find :unwind-protect clauses :key #'caar)) (basic-restart-clause (find :basic-restart clauses :key #'caar))) `(do ((,context ,(if start-context start-context '(current-dynamic-context)) @@ -134,7 +147,8 @@ (multiple-value-bind ,(cdar bind-clause) (values ,context (stack-frame-ref nil ,context 0 :lisp) - (stack-frame-ref nil ,context 2 :lisp)) + (stack-frame-ref nil ,context 2 :lisp) + (stack-frame-ref nil ,context 1 :lisp)) ,@(rest bind-clause))))) ,@(when up-clause `(((eq ,tag (load-global-constant unwind-protect-tag)) @@ -153,29 +167,48 @@ (stack-frame-ref nil ,context -1 :lisp)) ; name 0 (length (cdar basic-restart-clause)))) ,@(rest basic-restart-clause)))))) + ,@(when lcatch-clause + `(((eq ,tag (load-global-constant unbound-function)) + (multiple-value-bind ,(cdar lcatch-clause) + (values ,context) + ,@(rest lcatch-clause))))) ,@(when catch-clause `((t (multiple-value-bind ,(cdar catch-clause) (values ,context ,tag) ,@(rest catch-clause)))))))))) -(defun pdc (&rest types) - (declare (dynamic-extent types)) - (let ((types (or types '(:restarts :bindings :catch)))) - (with-each-dynamic-context () - ((:basic-restart context name) - (when (member :restarts types) - (format t "~&restart: ~S fmt: ~S/~S [#x~X]" name - (rc-format context) - (rc-args context) - context))) - ((:binding context name value) - (declare (ignore context)) - (when (member :bindings types) - (format t "~&bind: ~S => ~Z" name value))) - ((:catch context tag) - (declare (ignore context)) - (when (member :catch types) - (format t "~&catch: ~Z: ~S" tag tag)))))) + +(defun print-dynamic-context (&key + (types '(:restart :binding :catch :unwind-protect :lexical-catch) types-p) + variables (spartan t) (show-functions t)) + (when (and variables (not types-p)) + (setf types '(:binding))) + (let ((format-values (if spartan "~Z" "~S")) + (last-frame nil)) + (flet ((info (context type format &rest args) + (when (member type types) + (let ((frame (stack-index-frame nil context (current-stack-frame)))) + (when (and show-functions frame (not (eq frame last-frame))) + (setf last-frame frame) + (format t "~& [[[in ~A]]]~%" (stack-frame-funobj nil frame)))) + (format t "~&[~8,'0X] " context) + (apply #'format t format args)))) + (with-each-dynamic-context () + ((:basic-restart context name) + (info context :basic-restart + "restart: ~S fmt: ~S/~S [#x~X]" + name (rc-format context) (rc-args context) context)) + ((:binding context name value scratch) + (when (or (null variables) + (member name variables)) + (info context :binding "bind: ~S => ~@? [scratch: ~@?]" + name format-values value format-values scratch))) + ((:unwind-protect context) + (info context :unwind-protect "unwind-protect")) + ((:lexical-catch context tag) + (info context :lexical-catch "lexical-catch" tag tag)) + ((:catch context tag) + (info context :catch "catch: ~Z: ~S" tag tag)))))) (define-compiler-macro %location-object (&environment env location tag) (assert (movitz:movitz-constantp tag env))

1 0

[movitz-cvs] CVS movitz/losp/lib
by ffjeld 12 Apr '07

12 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/lib In directory clnet:/tmp/cvs-serv9643 Modified Files: shallow-binding.lisp Log Message: Rename package to lib.shallow-binding. --- /project/movitz/cvsroot/movitz/losp/lib/shallow-binding.lisp 2007/04/09 17:30:30 1.1 +++ /project/movitz/cvsroot/movitz/losp/lib/shallow-binding.lisp 2007/04/12 16:09:27 1.2 @@ -7,18 +7,18 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: shallow-binding.lisp,v 1.1 2007/04/09 17:30:30 ffjeld Exp $ +;;;; $Id: shallow-binding.lisp,v 1.2 2007/04/12 16:09:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(defpackage los0.shallow-binding +(defpackage lib.shallow-binding (:use common-lisp muerte) (:export #:install-shallow-binding #:deinstall-shallow-binding)) (provide :lib/shallow-binding) -(in-package los0.shallow-binding) +(in-package lib.shallow-binding) (define-primitive-function dynamic-variable-install-shallow () "Install each dynamic binding entry between that in ESP @@ -103,6 +103,7 @@ (:movl (:ecx) :eax) ; symbol? (:testb 3 :al) ; (:jz 'not-variable-binding) ; not symbol? + (:movl :ebx (:eax (:offset movitz-symbol value))) ; uninstall. not-variable-binding (:movl (:ecx 12) :ecx) ; proceed search

1 0

[movitz-cvs] CVS movitz
by ffjeld 11 Apr '07

11 Apr '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv7978 Modified Files: special-operators-cl.lisp Log Message: Fix unwind-protect compiler: do dynamic-unwind-next _after_ the cleanup-forms have executed (ticket #6). --- /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2007/04/02 20:54:34 1.52 +++ /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2007/04/11 22:09:39 1.53 @@ -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.52 2007/04/02 20:54:34 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.53 2007/04/11 22:09:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1338,12 +1338,15 @@ :form `(muerte::with-cloak (:multiple-values) ;; Inside here we don't have to mind current-values. (muerte::with-inline-assembly (:returns :nothing) - ;; First, find next-continuation-step.. - (:locally (:movl (:edi (:edi-offset raw-scratch0)) :eax)) ; final-cont.. + ;; First, save final-continuation across cleanup-forms. + (:locally (:pushl (:edi (:edi-offset raw-scratch0))))) + ,@cleanup-forms + (muerte::with-inline-assembly (:returns :nothing) + ;; Now, find next-continuation-step.. + (:popl :eax) ; final-continuation (:locally (:call (:edi (:edi-offset dynamic-unwind-next)))) (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax)) - (:store-lexical ,next-continuation-step-binding :eax :type t)) - ,@cleanup-forms)) + (:store-lexical ,next-continuation-step-binding :eax :type t)))) `((:locally (:popl (:edi (:edi-offset raw-scratch0)))) ; pop final continuation (:load-lexical ,next-continuation-step-binding :edx) (:locally (:movl :edx (:edi (:edi-offset dynamic-env))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27301 Modified Files: format.lisp Log Message: Add support for format "~@?". --- /project/movitz/cvsroot/movitz/losp/muerte/format.lisp 2007/04/08 13:14:58 1.16 +++ /project/movitz/cvsroot/movitz/losp/muerte/format.lisp 2007/04/09 21:10:48 1.17 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Mar 23 01:18:36 2002 ;;;; -;;;; $Id: format.lisp,v 1.16 2007/04/08 13:14:58 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.17 2007/04/09 21:10:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -315,11 +315,13 @@ (#\( (multiple-value-setq (i args) (format-by-string control-string (1+ i) loop-limit args (cond - ((and colon-p at-sign-p) :upcase) + ((and colon-p at-sign-p) :upcase) (colon-p :capitalize) (at-sign-p :capitalize-first) (t :downcase))))) - (#\? (format-by-string (pop args) 0 0 (pop args))) + (#\? (if (not at-sign-p) + (format-by-string (pop args) 0 0 (pop args)) + (setf args (nth-value 1 (format-by-string (pop args) 0 0 args))))) (#\: (setf colon-p t) (go proceed)) (#\@ (setf at-sign-p t)

1 0

[movitz-cvs] CVS movitz/grub-bootloader
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/grub-bootloader In directory clnet:/tmp/cvs-serv16701 Modified Files: grub-bootloader.img Log Message: New bootloader Binary files /project/movitz/cvsroot/movitz/grub-bootloader/grub-bootloader.img 2004/01/13 11:05:04 1.1.1.1 and /project/movitz/cvsroot/movitz/grub-bootloader/grub-bootloader.img 2007/04/09 18:02:16 1.2 differ

1 0

[movitz-cvs] CVS movitz/grub-bootloader
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/grub-bootloader In directory clnet:/tmp/cvs-serv13449 Modified Files: menu.txt Log Message: New menu --- /project/movitz/cvsroot/movitz/grub-bootloader/menu.txt 2004/01/13 11:05:04 1.1.1.1 +++ /project/movitz/cvsroot/movitz/grub-bootloader/menu.txt 2007/04/09 17:50:39 1.2 @@ -2,7 +2,7 @@ timeout 5 title Movitz/Los0 -kernel 250+2630 +kernel 200+20000 title Harddisk root (hd0,0)

1 0

[movitz-cvs] CVS movitz/losp/lib
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/lib In directory clnet:/tmp/cvs-serv4941 Added Files: shallow-binding.lisp Log Message: Renamed the 'muerte.init' package to 'los0'. Refactored the los0.lisp file such that most of the cruft is moved into scratch.lisp, the shallow-binding stuff is moved into lib/shallow-binding.lisp, and what remains in los0.lisp is just the core mechanisms for the los0 kernel application. --- /project/movitz/cvsroot/movitz/losp/lib/shallow-binding.lisp 2007/04/09 17:30:31 NONE +++ /project/movitz/cvsroot/movitz/losp/lib/shallow-binding.lisp 2007/04/09 17:30:31 1.1 ;;;;------------------ -*- movitz-mode: t -*-------------------------- ;;;; ;;;; Copyright (C) 2007, Frode Vatvedt Fjeld ;;;; ;;;; Filename: shallow-binding.lisp ;;;; Description: An implementation of shallow binding. ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; ;;;; $Id: shallow-binding.lisp,v 1.1 2007/04/09 17:30:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (defpackage los0.shallow-binding (:use common-lisp muerte) (:export #:install-shallow-binding #:deinstall-shallow-binding)) (provide :lib/shallow-binding) (in-package los0.shallow-binding) (define-primitive-function dynamic-variable-install-shallow () "Install each dynamic binding entry between that in ESP (offset by 4 due to the call to this primitive-function!) and current dynamic-env. Preserve EDX." (with-inline-assembly (:returns :nothing) (:leal (:esp 4) :ecx) ; first entry install-loop (:locally (:cmpl :ecx (:edi (:edi-offset dynamic-env)))) (:je 'install-completed) (:movl (:ecx 0) :eax) ; binding's name (:movl (:eax (:offset movitz-symbol value)) :ebx) ; old value into EBX (:movl :ebx (:ecx 4)) ; save old value in scratch (:movl (:ecx 8) :ebx) ; new value.. (:movl :ebx ; ..into symbol's value slot (:eax (:offset movitz-symbol value))) (:movl (:ecx 12) :ecx) ; iterate next binding (:jmp 'install-loop) install-completed (:ret))) (define-primitive-function dynamic-variable-uninstall-shallow (dynamic-env) "Uninstall each dynamic binding between 'here' (i.e. the current dynamic environment pointer) and the dynamic-env pointer provided in EDX. This must be done without affecting 'current values'! (i.e. eax, ebx, ecx, or CF), and also EDX must be preserved." (with-inline-assembly (:returns :nothing) (:jc 'ecx-ok) (:movl 1 :ecx) ecx-ok (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) (:locally (:movl :eax (:edi (:edi-offset scratch1)))) (:locally (:movl :ebx (:edi (:edi-offset scratch2)))) (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) uninstall-loop (:cmpl :edx :ecx) (:je 'uninstall-completed) (:movl (:ecx 0) :eax) ; symbol (:movl (:ecx 4) :ebx) ; old value (:movl :ebx (:eax (:offset movitz-symbol value))) ; reload old value (:movl (:ecx 12) :ecx) (:jmp 'uninstall-loop) uninstall-completed (:locally (:movl (:edi (:edi-offset raw-scratch0)) :ecx)) (:locally (:movl (:edi (:edi-offset scratch1)) :eax)) (:locally (:movl (:edi (:edi-offset scratch2)) :ebx)) (:stc) (:ret))) (define-primitive-function dynamic-unwind-next-shallow (dynamic-env) "Locate the next unwind-protect entry between here and dynamic-env/EAX. If no such entry is found, return (same) dynamic-env in EAX and CF=0. Otherwise return the unwind-protect entry in EAX and CF=1. Preserve EDX. Point is: Return the 'next step' in unwinding towards dynamic-env. Note that it's an error if dynamic-env isn't in the current dynamic environment, it's supposed to have been found by e.g. dynamic-locate-catch-tag." ;; XXX: Not really sure if there's any point in the CF return value, ;; because I don't think there's ever any need to know whether ;; the returned entry is an unwind-protect or the actual target. (with-inline-assembly (:returns :nothing) (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax)) (:locally (:movl :eax (:edi (:edi-offset scratch2)))) ; Free up EAX ;; (:globally (:movl (:edi (:edi-offset unwind-protect-tag)) :ebx)) (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) search-loop (:jecxz '(:sub-program () (:int 63))) (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) (:locally (:cmpl :ecx (:edi (:edi-offset scratch2)))) (:je 'found-dynamic-env) (:movl (:ecx 4) :ebx) (:globally (:cmpl :ebx (:edi (:edi-offset unwind-protect-tag)))) (:je 'found-unwind-protect) ;; If this entry is a dynamic variable binding, uninstall it. (:movl (:ecx) :eax) ; symbol? (:testb 3 :al) ; (:jz 'not-variable-binding) ; not symbol? (:movl :ebx (:eax (:offset movitz-symbol value))) ; uninstall. not-variable-binding (:movl (:ecx 12) :ecx) ; proceed search (:jmp 'search-loop) found-unwind-protect (:stc) found-dynamic-env (:movl :ecx :eax) (:ret))) (define-primitive-function dynamic-variable-lookup-shallow (symbol) "Load the dynamic value of SYMBOL into EAX." (with-inline-assembly (:returns :multiple-values) (:movl (:ebx (:offset movitz-symbol value)) :eax) (:ret))) (define-primitive-function dynamic-variable-store-shallow (symbol value) "Store VALUE (ebx) in the dynamic binding of SYMBOL (eax). Preserves EBX and EAX." (with-inline-assembly (:returns :multiple-values) (:movl :ebx (:eax (:offset movitz-symbol value))) (:ret))) (defun install-shallow-binding (&key quiet) (unless quiet (warn "Installing shallow-binding strategy..")) (without-interrupts (macrolet ((install (slot function) `(setf (%run-time-context-slot nil ',slot) (symbol-value ',function)))) (install muerte:dynamic-variable-install dynamic-variable-install-shallow) (install muerte:dynamic-variable-uninstall dynamic-variable-uninstall-shallow) (install muerte::dynamic-unwind-next dynamic-unwind-next-shallow) (install muerte::dynamic-variable-store dynamic-variable-store-shallow) (install muerte::dynamic-variable-lookup dynamic-variable-lookup-shallow)) (labels ((install-shallow-env (env) "We use this local function in order to install dynamic-env slots in reverse order, by depth-first recursion." (unless (eq 0 env) (install-shallow-env (memref env 12)) (let ((name (memref env 0))) (when (symbolp name) (setf (memref env 4) (%symbol-global-value name)) (setf (%symbol-global-value name) (memref env 8))))))) (install-shallow-env (%run-time-context-slot nil 'muerte::dynamic-env)))) (values)) (defun deinstall-shallow-binding (&key quiet) (unless quiet (warn "Deinstalling shallow-binding strategy..")) (without-interrupts (macrolet ((install (slot) `(setf (%run-time-context-slot nil ',slot) (symbol-value ',slot)))) (install muerte:dynamic-variable-install) (install muerte:dynamic-variable-uninstall) (install muerte::dynamic-unwind-next) (install muerte::dynamic-variable-store) (install muerte::dynamic-variable-lookup)) (loop for env = (%run-time-context-slot nil 'muerte::dynamic-env) then (memref env 12) while (plusp env) do (let ((name (memref env 0))) (when (symbolp name) (setf (%symbol-global-value name) (memref env 4))))) (values)))

1 0

[movitz-cvs] CVS movitz/losp
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/losp In directory clnet:/tmp/cvs-serv4903 Added Files: scratch.lisp Log Message: Renamed the 'muerte.init' package to 'los0'. Refactored the los0.lisp file such that most of the cruft is moved into scratch.lisp, the shallow-binding stuff is moved into lib/shallow-binding.lisp, and what remains in los0.lisp is just the core mechanisms for the los0 kernel application. --- /project/movitz/cvsroot/movitz/losp/scratch.lisp 2007/04/09 17:30:22 NONE +++ /project/movitz/cvsroot/movitz/losp/scratch.lisp 2007/04/09 17:30:22 1.1 ;;;;------------------ -*- movitz-mode: t -*-------------------------- ;;;; ;;;; Copyright (C) 2007, Frode Vatvedt Fjeld ;;;; ;;;; Filename: scratch.lisp ;;;; Description: Misc. testing code etc. ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Distribution: See the accompanying file COPYING. ;;;; ;;;; $Id: scratch.lisp,v 1.1 2007/04/09 17:30:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (provide :scratch) (in-package los0) #+ignore (defun set.2 () (let ((*var-used-in-set-tests* 'a) (var '*var-used-in-set-tests*)) (declare (special *var-used-in-set-tests*)) (values (let ((*var-used-in-set-tests* 'c)) (list (set var 'b) *var-used-in-set-tests* (symbol-value var))) *var-used-in-set-tests*))) ;; (b c b) ;; b) #+ignore (defun test-lend-constant () (let ((symbols '(a b c d e f g h i j k l m n o p q r s t u v w x y z)) (table (make-hash-table :test #'eq))) (loop for sym in symbols for i from 1 do (setf (gethash sym table) i)) (let ((sum 0)) (values (maphash #'(lambda (k v) (assert (eq (elt symbols (1- v)) k)) (incf sum v)) table) sum)))) #+ignore (defun test-aux (x y &aux (sum (+ x y))) sum) #+ignore (defun mapc.error.3 () (mapc #'append)) #+ignore (defun with-hash-table-iterator.12 () (block done (let ((x :bad)) (declare (special x)) (let ((x :good)) (with-hash-table-iterator (m (return-from done x)) (declare (special x)))))) :good) #+ignore (defun string.15 () (when (> char-code-limit 65536) (loop for i = (random char-code-limit) for c = (code-char i) for s = (and c (string c)) repeat 2000 when (and c (or (not (stringp s)) (not (= (length s) 1)) (not (eql c (char s 0))))) collect (list i c s))) nil) (defun x (bios32) (warn "X: ~S" (memref-int bios32)) (warn "X: ~S" (= (memref-int bios32) #x5f32335f))) (defun test2 () (funcall (compile nil '(lambda (a) (declare (notinline > *)) (declare (optimize (compilation-speed 0) (safety 2) (speed 2) (debug 0) (space 3))) (catch 'ct1 (* a (throw 'ct1 (if (> 0) a 0)))))) 5445205692802)) (defun test3 () (loop for x below 2 count (not (not (typep x t))))) (defun test4 () (let ((aa 1)) (if (not (/= aa 0)) aa 0))) (defun test-floppy () (muerte.x86-pc::fd-start-disk) ; to initialize the controller and spin the drive up. (muerte.x86-pc::fd-cmd-seek 70) ; to seek to track 70. (setf (muerte.x86-pc::fd-motor) nil)) ; to turn the drive and controller off. (defun alist-get-expand (alist key) (let (cons) (tagbody loop (setq cons (car alist)) (cond ((eq alist nil) (go end)) ((eq cons nil)) ((eq key (car cons)) (go end))) (setq alist (cdr alist)) (go loop) end) (cdr cons))) ;;;(defun test-irq () ;;; (with-inline-assembly (:returns :multiple-values) ;;; (:compile-form (:result-mode :multiple-values) (values 0 1 2 3 4 5)) ;;; (:int 42))) ;;; ;;;(defun koo () ;;; (prog1 (make-values) ;;; (format t "hello: ~S" (values 'a 'b 'c 'd)))) ;;; ;;;(defun test-complement (&rest args) ;;; (declare (dynamic-extent args)) ;;; (apply (complement #'symbolp) args)) ;;; ;;;(defun test-constantly (&rest args) ;;; (declare (dynamic-extent args)) ;;; (apply (constantly 'test-value) args)) (defun test-closure (x z) (flet ((closure (y) (= x (1+ y)))) (declare (dynamic-extent (function closure))) (closure z) #+ignore (funcall (lambda (y) (= x (1+ y))) z))) (defun test-stack-cons (x y) (muerte::with-dynamic-extent-scope (zap) (let ((foo (muerte::with-dynamic-extent-allocation (zap) (cons x (lambda () y))))) (format t "~Z: ~S, ~S" foo foo (funcall (cdr foo)))))) (defun test-handler (x) (let ((foo x)) (handler-bind ((error (lambda (c) (format t "error: ~S ~S" c x)))) (error "This is an error. ~S" foo)))) (defun fooo (v w) (tagbody (print (block blurgh (progv (list v) (list w) (format t "Uh: ~S" (symbol-value v)) (if (symbol-value v) (return-from blurgh 1) (go zap))))) zap) t) (defun test-break () (with-inline-assembly (:returns :multiple-values) (:movl 10 :ecx) (:movl :esi :eax) ; This function should return itself! (:clc) (:break))) (defun test-upload (x) ;; (warn "Test-upload blab la bla!!") (setf x (cdr x)) x) ;;;(defun zzz (x) ;;; (multiple-value-bind (symbol status) ;;; (values-list x) ;;; (warn "sym: ~S, stat: ~S" symbol status))) ;;; #+ignore (defun test-loop (x) (format t "test-loop: ~S~%" (loop for i from 0 to 10 collect x))) #+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) ;;; (:compile-form (:result-mode :ecx) x) ;;; (:leal (:edi -4) :eax) ;;; (:rorb :cl :al))) #+ignore (defun test-block (x) (block nil (let ((*print-base* (if x (return 3) 8))) (jumbo 2 2 (and x 2) (+ 3 3 (or x 4)) (if x 2 (return nil))))) #+ignore (+ x 2)) #+ignore (defun jumbo (a b c &rest x) (declare (dynamic-extent x)) (print a) (print b) (print c) (print x) 'jumbo) (defun jumbo2 (a b &rest x) (declare (dynamic-extent x)) (print a) (print b) (print x) 'jumbo) (defun jumbo3 (a &rest x) (declare (dynamic-extent x)) (print a) (print x) 'jumbo) (defun jumbo4 (&rest x) (declare (dynamic-extent x)) (print x) 'jumbo) #+ignore (defun tagbodyxx (x) (tagbody (print 'hello) haha (unwind-protect (when x (go hoho)) (warn "unwind..")) (print 'world) hoho (print 'blrugh))) #+ignore (defun tagbodyxx (x) (tagbody (print 'hello) haha (unwind-protect (funcall (lambda () (when x (go hoho)))) (warn "unwind..")) (print 'world) hoho (print 'blrugh))) #+ignore (defun kumbo (&key a b (c (jumbo 1 2 3)) d) (print a) (print b) (print c) (print d)) #+ignore (defun lumbo (a &optional (b 'zap)) (print a) (print b)) (defmacro do-check-esp (&body body) `(let ((before (with-inline-assembly (:returns :eax) (:movl :esp :eax)))) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :multiple-values) (progn ,@body))) (unless (eq before (with-inline-assembly (:returns :eax) (:movl :esp :eax))) (error "ESP before body: ~S, after: ~S" (with-inline-assembly (:returns :eax) (:movl :esp :eax)))))) #+ignore (defun test-m-v-call () (do-check-esp (multiple-value-call #'format t "~@{ ~D~}~%" 'a (values) 'b (test-loop 1) (make-values) 'c 'd 'e (make-no-values) 'f))) (defun test-m-v-call2 () (multiple-value-call #'format t "~@{ ~D~}~%" 'a 'b (values 1 2 3) 'c 'd 'e 'f)) (defun make-values () (values 0 1 2 3 4 5)) (defun xfuncall (&rest args) (declare (dynamic-extent args)) (break "xfuncall:~{ ~S~^,~}" args) (values)) (defun xfoo (f) (do-check-esp (multiple-value-bind (a b c d) (multiple-value-prog1 (make-values) (format t "hello world")) (format t "~&a: ~S, b: ~S, c: ~S, d: ~S ~S" a b c d f)))) #+ignore (defun make-no-values () (values)) #+ignore (defun test-nth-values () (nth-value 2 (make-values))) #+ignore (defun test-values2 () (multiple-value-bind (a b c d e f g h) (make-values) (format t "test-values2: A: ~S, B: ~S, C: ~S, D: ~S, E: ~S, F: ~S G: ~S, H: ~S~%" a b c d e f g h))) #+ignore (defun test-flet (zap) (flet ((pingo (z y x) (declare (ignore y z)) (format t "This is pingo: ~S with zap: ~W~%" x zap))) ;; (declare (dynamic-extent pingo)) (pingo 100 200 300))) #+ignore (defun test-flet2 (zap) (flet ((pingo (z y x) (declare (ignore y z)) (format t "This is pingo: ~S with zap: ~W~%" x zap))) ;; (declare (dynamic-extent pingo)) (lambda (x) (pingo 100 200 300)))) (defun test-boo () (let ((real-cmuc #'test-flet2)) (let ((plongo (lambda (x) (warn "~S real-cmuc: ~S" x real-cmuc) (funcall real-cmuc x)))) (funcall plongo 'zooom)))) (defun test-labels () (labels ((pingo (x) (format t "~&This is pingo: ~S~%" x) (when (plusp x) (pingo (1- x))))) (pingo 5))) #+ignore (defun foo-type (length start1 sequence-1) (do* ((i 0 #+ignore (+ start1 length -1) (1- i))) ((< i start1) sequence-1) (declare (type muerte::index i length)) (setf (sequence-1-ref i) 'foo))) #+ignore (defun test-values () (multiple-value-bind (a b c d e f g h i j) (multiple-value-prog1 (make-values) ;;; (format t "this is the resulting form.~%") (format t "this is the first ignorable form.~%" 1 2 3) (format t "this is the second ignorable form.~%")) ;;; (format t "test-values num: ~D~%" (capture-reg8 :cl)) (format t "test-values: A: ~Z, B: ~Z, C: ~Z, D: ~Z ~Z ~Z ~Z ~Z ~Z ~Z~%" a b c d e f g h i j))) #+ignore (defun test-keywords (&key a b (c 100) ((:d x) 5 x-p)) (format t "test-keywords: a: ~S, b: ~S, c: ~S, x: ~S, x-p: ~S~%" a b c x x-p)) #+ignore (defun test-k1 (a b &key x) (declare (ignore a b)) (warn "x: ~S" x)) (defun test-funcall (&rest args) (declare (dynamic-extent args)) (format t "~&test-funcall args: ~S~%" args)) #+ignore (defun test-rest (&optional (a0 nil a0-p) a1 a3 &rest args) (declare (dynamic-extent args)) (when a0-p (format t "args: ~S, ~S, ~S: ~S~%" a0 a1 a3 args))) (defun test-return () (print (block nil (values 'x 'y (if (foo) (return 'foo) (return-from test-return 'not-foo)) 'bar))) 5) #+ignore (defun test-lexthrow (x) [749 lines skipped]

1 0

[movitz-cvs] CVS movitz/losp
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/losp In directory clnet:/tmp/cvs-serv4851 Modified Files: los0.lisp Log Message: Renamed the 'muerte.init' package to 'los0'. Refactored the los0.lisp file such that most of the cruft is moved into scratch.lisp, the shallow-binding stuff is moved into lib/shallow-binding.lisp, and what remains in los0.lisp is just the core mechanisms for the los0 kernel application. --- /project/movitz/cvsroot/movitz/losp/los0.lisp 2005/10/31 09:18:08 1.50 +++ /project/movitz/cvsroot/movitz/losp/los0.lisp 2007/04/09 17:30:15 1.51 @@ -1,4 +1,4 @@ -;;;;------------------------------------------------------------------ +;;;;------------------ -*- movitz-mode: t -*-------------------------- ;;;; ;;;; Copyright (C) 2000-2005, ;;;; Department of Computer Science, University of Tromso, Norway @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.50 2005/10/31 09:18:08 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.51 2007/04/09 17:30:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -33,8 +33,7 @@ ;; (require :lice-0.1/all) -(defpackage muerte.init - (:nicknames #:los0) +(defpackage los0 (:use #:common-lisp #:muerte #:muerte.lib @@ -49,742 +48,15 @@ #:muerte.x86-pc.serial #:threading)) +(require :lib/shallow-binding) (require :los0-gc) ; Must come after defpackage. +;; (require :asteroids) +(require :scratch) -(in-package muerte.init) - -(defun test0 () - (ash 1 -1000000000000)) - -(defun test1 () - (unwind-protect 0 (the integer 1))) - -(defun x (bios32) - (warn "X: ~S" (memref-int bios32)) - (warn "X: ~S" (= (memref-int bios32) #x5f32335f))) - -(defun test2 () - (funcall - (compile - nil - '(lambda (a) (declare (notinline > *)) - (declare (optimize (compilation-speed 0) (safety 2) (speed 2) (debug 0) (space 3))) - (catch 'ct1 (* a (throw 'ct1 (if (> 0) a 0)))))) - 5445205692802)) - -(defun test3 () - (loop for x below 2 count (not (not (typep x t))))) - -(defun test4 () - (let ((aa 1)) (if (not (/= aa 0)) aa 0))) - - -(defun test-floppy () - (muerte.x86-pc::fd-start-disk) ; to initialize the controller and spin the drive up. - (muerte.x86-pc::fd-cmd-seek 70) ; to seek to track 70. - (setf (muerte.x86-pc::fd-motor) nil)) ; to turn the drive and controller off. - - -(defun alist-get-expand (alist key) - (let (cons) - (tagbody - loop - (setq cons (car alist)) - (cond ((eq alist nil) (go end)) - ((eq cons nil)) - ((eq key (car cons)) (go end))) - (setq alist (cdr alist)) - (go loop) - end) - (cdr cons))) - -;;;(defun test-irq () -;;; (with-inline-assembly (:returns :multiple-values) -;;; (:compile-form (:result-mode :multiple-values) (values 0 1 2 3 4 5)) -;;; (:int 42))) -;;; -;;;(defun koo () -;;; (prog1 (make-values) -;;; (format t "hello: ~S" (values 'a 'b 'c 'd)))) -;;; -;;;(defun test-complement (&rest args) -;;; (declare (dynamic-extent args)) -;;; (apply (complement #'symbolp) args)) -;;; -;;;(defun test-constantly (&rest args) -;;; (declare (dynamic-extent args)) -;;; (apply (constantly 'test-value) args)) - -(defun test-closure (x z) - (flet ((closure (y) (= x (1+ y)))) - (declare (dynamic-extent (function closure))) - (closure z) - #+ignore (funcall (lambda (y) (= x (1+ y))) - z))) - -(defun test-stack-cons (x y) - (muerte::with-dynamic-extent-scope (zap) - (let ((foo (muerte::with-dynamic-extent-allocation (zap) - (cons x (lambda () y))))) - (format t "~Z: ~S, ~S" foo foo (funcall (cdr foo)))))) - -(defun test-handler (x) - (let ((foo x)) - (handler-bind - ((error (lambda (c) - (format t "error: ~S ~S" c x)))) - (error "This is an error. ~S" foo)))) - - -(defun fooo (v w) - (tagbody - (print (block blurgh - (progv (list v) (list w) - (format t "Uh: ~S" (symbol-value v)) - (if (symbol-value v) - (return-from blurgh 1) - (go zap))))) - zap) - t) - - -(defun test-break () - (with-inline-assembly (:returns :multiple-values) - (:movl 10 :ecx) - (:movl :esi :eax) ; This function should return itself! - (:clc) - (:break))) - -(defun test-upload (x) - ;; (warn "Test-upload blab la bla!!") - (setf x (cdr x)) - x) - -;;;(defun zzz (x) -;;; (multiple-value-bind (symbol status) -;;; (values-list x) -;;; (warn "sym: ~S, stat: ~S" symbol status))) -;;; - -#+ignore -(defun test-loop (x) - (format t "test-loop: ~S~%" - (loop for i from 0 to 10 collect x))) - -#+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) -;;; (:compile-form (:result-mode :ecx) x) -;;; (:leal (:edi -4) :eax) -;;; (:rorb :cl :al))) - - -#+ignore -(defun test-block (x) - (block nil - (let ((*print-base* (if x (return 3) 8))) - (jumbo 2 2 (and x 2) (+ 3 3 (or x 4)) (if x 2 (return nil))))) - #+ignore (+ x 2)) - -#+ignore -(defun jumbo (a b c &rest x) - (declare (dynamic-extent x)) - (print a) (print b) (print c) - (print x) - 'jumbo) - -(defun jumbo2 (a b &rest x) - (declare (dynamic-extent x)) - (print a) (print b) - (print x) - 'jumbo) - -(defun jumbo3 (a &rest x) - (declare (dynamic-extent x)) - (print a) - (print x) - 'jumbo) - -(defun jumbo4 (&rest x) - (declare (dynamic-extent x)) - (print x) - 'jumbo) - -#+ignore -(defun tagbodyxx (x) - (tagbody - (print 'hello) - haha - (unwind-protect - (when x (go hoho)) - (warn "unwind..")) - (print 'world) - hoho - (print 'blrugh))) - -#+ignore -(defun tagbodyxx (x) - (tagbody - (print 'hello) - haha - (unwind-protect - (funcall (lambda () - (when x (go hoho)))) - (warn "unwind..")) - (print 'world) - hoho - (print 'blrugh))) - -#+ignore -(defun kumbo (&key a b (c (jumbo 1 2 3)) d) - (print a) - (print b) - (print c) - (print d)) - -#+ignore -(defun lumbo (a &optional (b 'zap)) - (print a) - (print b)) - -(defmacro do-check-esp (&body body) - `(let ((before (with-inline-assembly (:returns :eax) (:movl :esp :eax)))) - (with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :multiple-values) (progn ,@body))) - (unless (eq before - (with-inline-assembly (:returns :eax) (:movl :esp :eax))) - (error "ESP before body: ~S, after: ~S" - (with-inline-assembly (:returns :eax) (:movl :esp :eax)))))) - -#+ignore -(defun test-m-v-call () - (do-check-esp - (multiple-value-call #'format t "~@{ ~D~}~%" - 'a (values) 'b (test-loop 1) (make-values) - 'c 'd 'e (make-no-values) 'f))) - -(defun test-m-v-call2 () - (multiple-value-call #'format t "~@{ ~D~}~%" - 'a 'b (values 1 2 3) 'c 'd 'e 'f)) - -(defun make-values () - (values 0 1 2 3 4 5)) - -(defun xfuncall (&rest args) - (declare (dynamic-extent args)) - (break "xfuncall:~{ ~S~^,~}" args) - (values)) - -(defun xfoo (f) - (do-check-esp - (multiple-value-bind (a b c d) - (multiple-value-prog1 (make-values) - (format t "hello world")) - (format t "~&a: ~S, b: ~S, c: ~S, d: ~S ~S" a b c d f)))) - - -#+ignore -(defun make-no-values () - (values)) - -#+ignore -(defun test-nth-values () - (nth-value 2 (make-values))) - -#+ignore -(defun test-values2 () - (multiple-value-bind (a b c d e f g h) - (make-values) - (format t "test-values2: A: ~S, B: ~S, C: ~S, D: ~S, E: ~S, F: ~S G: ~S, H: ~S~%" - a b c d e f g h))) - -#+ignore -(defun test-flet (zap) - (flet ((pingo (z y x) - (declare (ignore y z)) - (format t "This is pingo: ~S with zap: ~W~%" x zap))) - ;; (declare (dynamic-extent pingo)) - (pingo 100 200 300))) - -#+ignore -(defun test-flet2 (zap) - (flet ((pingo (z y x) - (declare (ignore y z)) - (format t "This is pingo: ~S with zap: ~W~%" x zap))) - ;; (declare (dynamic-extent pingo)) - (lambda (x) - (pingo 100 200 300)))) - -(defun test-boo () - (let ((real-cmuc #'test-flet2)) - (let ((plongo (lambda (x) - (warn "~S real-cmuc: ~S" x real-cmuc) - (funcall real-cmuc x)))) - (funcall plongo 'zooom)))) - -(defun test-labels () - (labels ((pingo (x) - (format t "~&This is pingo: ~S~%" x) - (when (plusp x) - (pingo (1- x))))) - (pingo 5))) - -#+ignore -(defun foo-type (length start1 sequence-1) - (do* ((i 0 #+ignore (+ start1 length -1) (1- i))) - ((< i start1) sequence-1) - (declare (type muerte::index i length)) - (setf (sequence-1-ref i) - 'foo))) - - -#+ignore -(defun test-values () - (multiple-value-bind (a b c d e f g h i j) - (multiple-value-prog1 - (make-values) -;;; (format t "this is the resulting form.~%") - (format t "this is the first ignorable form.~%" 1 2 3) - (format t "this is the second ignorable form.~%")) -;;; (format t "test-values num: ~D~%" (capture-reg8 :cl)) - (format t "test-values: A: ~Z, B: ~Z, C: ~Z, D: ~Z ~Z ~Z ~Z ~Z ~Z ~Z~%" a b c d e f g h i j))) - - -#+ignore -(defun test-keywords (&key a b (c 100) ((:d x) 5 x-p)) - (format t "test-keywords: a: ~S, b: ~S, c: ~S, x: ~S, x-p: ~S~%" - a b c x x-p)) - -#+ignore -(defun test-k1 (a b &key x) - (declare (ignore a b)) - (warn "x: ~S" x)) - -(defun test-funcall (&rest args) - (declare (dynamic-extent args)) - (format t "~&test-funcall args: ~S~%" args)) - -#+ignore -(defun test-rest (&optional (a0 nil a0-p) a1 a3 &rest args) - (declare (dynamic-extent args)) - (when a0-p - (format t "args: ~S, ~S, ~S: ~S~%" a0 a1 a3 args))) - - -(defun test-return () - (print (block nil - (values 'x 'y (if (foo) (return 'foo) (return-from test-return 'not-foo)) 'bar))) - 5) - -#+ignore -(defun test-lexthrow (x) - (apply (lambda (a b) - (unwind-protect - (if (plusp a) 0 (return-from test-lexthrow (+ a b))) - (warn "To serve and protect!"))) - x)) - -#+ignore -(defun test-lexgo (x) - (let ((*print-base* 2)) - (return-from test-lexgo (print 123)))) - -#+ignore -(defun test-xgo (c x) - (tagbody - loop - (warn "c: ~S" c) - (apply (lambda (a) - (decf c) - (if (plusp a) (go exit) (go loop)) - (warn "juhu, a or x: ~S, c: ~S" a c)) - x) - exit - (warn "exited: ~S" c))) - - -(defun test-bignum () - 123456789123456) - -(defun fe32 () - #xfffffffe) - [1005 lines skipped]

1 0

[movitz-cvs] CVS movitz/losp
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/losp In directory clnet:/tmp/cvs-serv4744 Modified Files: los0-gc.lisp Log Message: Renamed the 'muerte.init' package to 'los0'. Refactored the los0.lisp file such that most of the cruft is moved into scratch.lisp, the shallow-binding stuff is moved into lib/shallow-binding.lisp, and what remains in los0.lisp is just the core mechanisms for the los0 kernel application. --- /project/movitz/cvsroot/movitz/losp/los0-gc.lisp 2006/10/27 06:23:32 1.61 +++ /project/movitz/cvsroot/movitz/losp/los0-gc.lisp 2007/04/09 17:30:09 1.62 @@ -10,13 +10,13 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.61 2006/10/27 06:23:32 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.62 2007/04/09 17:30:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (provide :los0-gc) -(in-package muerte.init) +(in-package los0) (defvar *gc-quiet* nil) (defvar *gc-running* nil) @@ -91,10 +91,22 @@ ((do-it () `(with-inline-assembly (:returns :eax) retry-cons - ;; Set up thread-atomical execution + +;; (:locally (:cmpl #xabbabee0 (:edi (:edi-offset values) ,(* 4 #x30)))) +;; (:je 'no-check) +;; (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) +;; (:movl (:edx 6) :edx); other +;; (:cmpl 8 (:edx 2)) +;; (:jne '(:sub-program () +;; (:locally (:movl #xabbabee0 (:edi (:edi-offset values) ,(* 4 #x30)))) +;; (:break))) +;; no-check + + ;; Set up thread-atomical execution (:locally (:movl ,(movitz::atomically-continuation-simple-pf 'fast-cons) (:edi (:edi-offset atomically-continuation)))) - (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) + + (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) (:movl (:edx 2) :ecx) (:cmpl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) :ecx) @@ -230,6 +242,18 @@ (defvar *gc-stack* nil) (defvar *gc-stack2* nil) +(defmacro with-hack-space ((&key (size 409600)) &body body) + `(let* ((id (with-inline-assembly (:returns :eax) (:movl :esp :eax))) + (save-space (%run-time-context-slot nil 'muerte::nursery-space)) + (hack-space (make-duo-space (duo-space-end-location save-space) ,size))) + (warn "[~A] hack-space ~Z from ~Z/~Z: ~A" id hack-space save-space (space-other save-space) ',body) + (unwind-protect + (progn + (setf (%run-time-context-slot nil 'muerte::nursery-space) hack-space) + ,@body) + (warn "[~A] hack-space done." id) + (setf (%run-time-context-slot nil 'muerte::nursery-space) save-space)))) + (defun install-los0-consing (&key (context (current-run-time-context)) (kb-size 1024) duo-space) @@ -240,26 +264,40 @@ (lambda (exception interrupt-frame) (declare (ignore exception interrupt-frame)) (without-interrupts - (let ((*standard-output* *terminal-io*)) - (cond - (*gc-running* - (let* ((full-space (%run-time-context-slot nil 'muerte::nursery-space)) - (hack-space (make-duo-space (duo-space-end-location full-space) 102400))) - (setf (%run-time-context-slot nil 'muerte::nursery-space) hack-space) - (break "Recursive GC triggered. Full-space: ~Z, hack-space: ~Z" - full-space hack-space))) - (t (let ((*gc-running* t)) - (unless *gc-quiet* - (format t "~&;; GC.. ")) - (stop-and-copy)))) + (let ((muerte::*active-condition-handlers* nil) + (*debugger-hook* nil) + (*standard-output* *terminal-io*)) + (cond + (*gc-running* + (let* ((full-space (%run-time-context-slot nil 'muerte::nursery-space)) + (hack-space (make-duo-space (duo-space-end-location full-space) 102400))) + (setf (%run-time-context-slot nil 'muerte::nursery-space) hack-space) + (break "Recursive GC triggered. Full-space: ~Z, hack-space: ~Z" + full-space hack-space))) + (t (let ((*gc-running* t)) + (unless *gc-quiet* + (format t "~&;; GC ~Z.." (%run-time-context-slot nil 'muerte::nursery-space))) + (let* ((space0 (%run-time-context-slot nil 'nursery-space)) + (space1 (space-other space0))) + (unless (= 2 (space-fresh-pointer space1)) + (with-hack-space () + (error "PRE space-other is not initialized: ~S" (space-fresh-pointer space1))))) + (unwind-protect + (stop-and-copy) + (let* ((space0 (%run-time-context-slot nil 'nursery-space)) + (space1 (space-other space0))) + (unless (= 2 (space-fresh-pointer space1)) + (with-hack-space () + (error "UP space-other is not initialized: ~S" (space-fresh-pointer space1)))) + ))))) (if *gc-break* (break "GC break.") - (loop ; This is a nice opportunity to poll the keyboard.. - (case (muerte.x86-pc.keyboard:poll-char) - ((#\escape) - (break "Los0 GC keyboard poll.")) - ((nil) - (return))))))))) + (loop ; This is a nice opportunity to poll the keyboard.. + (case (muerte.x86-pc.keyboard:poll-char) + ((#\escape) + (break "Los0 GC keyboard poll.")) + ((nil) + (return))))))))) (let* ((actual-duo-space (or duo-space (allocate-duo-space (* kb-size #x100)))) (last-location (object-location (cons 1 2)))) @@ -332,9 +370,12 @@ (values)))) -(defparameter *x* #4000(nil)) ; Have this in static space. +(defparameter *x* (make-array #x1000 :fill-pointer 0)) ; Have this in static space. ;;;(defparameter *xx* #4000(nil)) ; Have this in static space. +(defvar *gc-x1* nil) +(defvar *gc-x2* nil) + (defparameter *code-vector-foo* 0) (defvar *old-code-vectors* #250(nil)) (defvar *new-code-vectors* #250(nil)) @@ -349,7 +390,10 @@ (check-type space0 (simple-array (unsigned-byte 32) 1)) (check-type space1 (simple-array (unsigned-byte 32) 1)) (assert (eq space0 (space-other space1))) - (assert (= 2 (space-fresh-pointer space1))) + (unless (= 2 (space-fresh-pointer space1)) + (with-hack-space () + (error "space1 is not initialized: ~S" (space-fresh-pointer space1)) + nil)) (setf (%run-time-context-slot nil 'nursery-space) space1) (values space1 space0))) ;; Evacuate-oldspace is to be mapped over every potential pointer. @@ -364,31 +408,29 @@ nil) ((object-in-space-p newspace x) x) - #+ignore - ((and (typep x 'code-vector) - (not (object-in-space-p oldspace x)) - (not (object-in-space-p newspace x)) - (= (ldb (byte 12 0) (object-location x)) - (ldb (byte 12 0) *code-vector-foo*)) - (not (eq x (funobj-code-vector #'stop-and-copy))) - (not (eq x (symbol-value 'muerte::default-interrupt-trampoline))) -;;; (not (eq x (symbol-value 'muerte::ret-trampoline))) - (not (muerte::scavenge-find-pf (lambda (x y) x) (object-location x)))) - (let ((p (position (object-location x) *old-code-vectors*))) - (if p - (aref *new-code-vectors* p) - (setf (aref *new-code-vectors* - (vector-push (object-location x) *old-code-vectors*)) - (let ((new (shallow-copy x))) - (warn "[~S] Migrating ~@[~S ~]~Z => ~Z." - location - (muerte::locate-function (object-location x)) - x new) - new))))) + #+ignore ((and (typep x 'code-vector) + (not (object-in-space-p oldspace x)) + (not (object-in-space-p newspace x)) + (= (ldb (byte 12 0) (object-location x)) + (ldb (byte 12 0) *code-vector-foo*)) + (not (eq x (funobj-code-vector #'stop-and-copy))) + (not (eq x (symbol-value 'muerte::default-interrupt-trampoline))) + (not (muerte::scavenge-find-pf (lambda (x y) x) (object-location x)))) + (let ((p (position (object-location x) *old-code-vectors*))) + (if p + (aref *new-code-vectors* p) + (setf (aref *new-code-vectors* + (vector-push (object-location x) *old-code-vectors*)) + (let ((new (shallow-copy x))) + (warn "[~S] Migrating ~@[~S ~]~Z => ~Z." + location + (muerte::locate-function (object-location x)) + x new) + new))))) ((not (object-in-space-p oldspace x)) x) - ((when (typep x 'run-time-context) - (warn "Scavenging ~S" x))) + #+ignore ((when (typep x 'run-time-context) + (warn "Scavenging ~S" x))) (t (or (and (eq (object-tag x) (ldb (byte 3 0) (memref (object-location x) 0 :type :unsigned-byte8))) @@ -415,10 +457,12 @@ with scan-pointer of-type index = 2 as fresh-pointer of-type index = (space-fresh-pointer newspace) while (< scan-pointer fresh-pointer) - do (map-header-vals evacuator - (+ newspace-location scan-pointer) - (+ newspace-location (space-fresh-pointer newspace))) - (setf scan-pointer fresh-pointer)) + do (let ((start (+ newspace-location scan-pointer)) + (end (+ newspace-location (space-fresh-pointer newspace)))) + (map-header-vals evacuator start end) + (setf *gc-x1* start) + (setf *gc-x2* end)) + (setf scan-pointer fresh-pointer)) (when *gc-consistency-check* ;; Consistency check.. (map-stack-vector (lambda (x foo) @@ -426,7 +470,7 @@ x) nil (current-stack-frame)) - (with-simple-restart (continue "Ignore failed GC consistency check.") + (with-simple-restart (continue "Skip GC consistency check.") (without-interrupts (let ((a *x*)) ;; First, restore the state of old-space

1 0

[movitz-cvs] CVS movitz/losp/x86-pc
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv17892 Modified Files: textmode.lisp Log Message: Add a trivial e9-output "steam" function. --- /project/movitz/cvsroot/movitz/losp/x86-pc/textmode.lisp 2007/03/26 21:43:21 1.16 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/textmode.lisp 2007/04/09 16:05:25 1.17 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 15:38:56 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: textmode.lisp,v 1.16 2007/03/26 21:43:21 ffjeld Exp $ +;;;; $Id: textmode.lisp,v 1.17 2007/04/09 16:05:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -240,6 +240,17 @@ (defun write-word-lowlevel (word dest) (write-word-lowlevel-macro word dest)) +(defun e9-output (op &rest args) + (declare (dynamic-extent args)) + (ecase op + (muerte::stream-write-char + (setf (io-port #xe9 :unsigned-byte8) (char-code (car args)))) + (muerte::stream-fresh-line + (e9-output 'muerte::stream-write-char #\Newline) + t) + (local-echo-p + nil))) + (defun textmode-console (op &rest args) "This function can act as *terminal-io* without/before CLOS support." (declare (dynamic-extent args))

1 0

[movitz-cvs] CVS movitz/losp/lib
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/lib In directory clnet:/tmp/cvs-serv17076 Modified Files: malloc-init.lisp Log Message: Compute available memory correctly in initial allocator. --- /project/movitz/cvsroot/movitz/losp/lib/malloc-init.lisp 2005/05/05 20:52:40 1.7 +++ /project/movitz/cvsroot/movitz/losp/lib/malloc-init.lisp 2007/04/09 16:01:53 1.8 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Jan 9 15:57:22 2002 ;;;; -;;;; $Id: malloc-init.lisp,v 1.7 2005/05/05 20:52:40 ffjeld Exp $ +;;;; $Id: malloc-init.lisp,v 1.8 2007/04/09 16:01:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,7 +28,7 @@ (start-location (logand (+ kernel-end-location (1- 4096/4)) -4096/4)) ;; End-location is the end of the memory. (end-location (* (1- memsize-mb) 1024 1024/4))) - (muerte:malloc-initialize start-location end-location) + (muerte:malloc-initialize start-location (- end-location start-location)) (setf (cdar muerte::%memory-map%) end-location) (loop for x from kernel-end-location below start-location do (setf (memref x 0 :type :unsigned-byte32) 0))

1 0

[movitz-cvs] CVS movitz/ide
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/ide In directory clnet:/tmp/cvs-serv15038 Modified Files: movitz-slime.el Log Message: Add movitz-disassemble-primitive. --- /project/movitz/cvsroot/movitz/ide/movitz-slime.el 2007/03/13 20:42:13 1.5 +++ /project/movitz/cvsroot/movitz/ide/movitz-slime.el 2007/04/09 16:00:00 1.6 @@ -45,7 +45,7 @@ ((slime-eval '(cl:and (cl:find-package :movitz.ide) t))) ((not (slime-eval '(cl:and (cl:find-package :movitz) t))) (message "Movitz-mode: The Movitz package is not loaded.")) - (t (slime-eval-async + (t (slime-eval `(cl:progn (cl:load (cl:compile-file ,(concat movitz-slime-path "ide.lisp"))) nil))))) @@ -161,27 +161,23 @@ (options options)) (cond ((string= "function" defun-type) - (message "Movitz disassembling %s %s..." defun-type defun-name) + (message "Movitz disassembling %s '%s'..." defun-type defun-name) (slime-eval-async `(movitz.ide:movitz-disassemble ,defun-name ,package-name) (lambda (result) (slime-show-description result package-name) - (message "Movitz disassembling %s %s...done." defun-type defun-name)))) + (message "Movitz disassembling %s '%s'...done." defun-type defun-name)))) ((string= "method" defun-type) (message "Movitz disassembling %s '%s %s'..." defun-type defun-name lambda-list) (slime-eval-async `(movitz.ide:movitz-disassemble-method ,defun-name ,lambda-list ',options ,package-name) (lambda (result) (slime-show-description result package-name) (message "Movitz disassembling %s '%s %s'...done." defun-type defun-name lambda-list)))) - ;; ((string= "primitive-function" defun-type) - ;; (message "Movitz disassembling %s %s..." defun-type defun-name) - ;; (fi:eval-in-lisp - ;; "(cl:let ((defun-name (cl:let ((cl:*package* (cl:find-package :%s))) - ;; (cl:read-from-string \"%s\"))) - ;; (cl:*print-base* 16)) - ;; (movitz::movitz-disassemble-primitive defun-name))" - ;; fi:package defun-name) - ;; (switch-to-buffer "*common-lisp*") - ;; (message "Movitz disassembling %s %s...done." defun-type defun-name)) + ((string= "primitive-function" defun-type) + (message "Movitz disassembling %s '%s'..." defun-type defun-name) + (slime-eval-async `(movitz.ide:movitz-disassemble-primitive ,defun-name ,package-name) + (lambda (result) + (slime-show-description result package-name) + (message "Movitz disassembling %s '%s'...done." defun-type defun-name)))) (t (message "Don't know how to Movitz disassemble %s '%s'." defun-type defun-name)))))) (defun movitz-arglist (string)

1 0

[movitz-cvs] CVS movitz/ide
by ffjeld 09 Apr '07

09 Apr '07

Update of /project/movitz/cvsroot/movitz/ide In directory clnet:/tmp/cvs-serv14958 Modified Files: ide.lisp Log Message: Add movitz-disassemble-primitive. --- /project/movitz/cvsroot/movitz/ide/ide.lisp 2007/03/13 20:42:11 1.6 +++ /project/movitz/cvsroot/movitz/ide/ide.lisp 2007/04/09 15:59:43 1.7 @@ -13,6 +13,7 @@ #:compile-defun #:dump-image #:movitz-disassemble + #:movitz-disassemble-primitive #:movitz-disassemble-method #:movitz-arglist #:movitz-macroexpand)) @@ -49,6 +50,13 @@ (movitz:movitz-disassemble (get-sexpr printname (get-package package-printname)))))) +(defun movitz-disassemble-primitive (printname package-printname) + "Return the disassembly of SYMBOL-NAME's function as a string." + (with-image () + (with-output-to-string (*standard-output*) + (movitz::movitz-disassemble-primitive (get-sexpr printname + (get-package package-printname)))))) + (defun movitz-disassemble-method (gf-name lambda-list qualifiers package-name) (with-image () (let ((package (get-package package-name)))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 08 Apr '07

08 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv19367 Modified Files: arrays.lisp Log Message: Remove lingering debug statement. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/08 15:52:33 1.63 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/08 16:03:53 1.64 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.63 2007/04/08 15:52:33 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.64 2007/04/08 16:03:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1100,7 +1100,6 @@ (do-it)))) (cond ((integerp fill-pointer) - (warn "sfp len: ~s" (array-dimension array 0)) (setf (fill-pointer array) fill-pointer)) ((or (eq t fill-pointer) (array-has-fill-pointer-p array))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 08 Apr '07

08 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv16794 Modified Files: arrays.lisp Log Message: Fixed a stupid bug in (setf fill-pointer) which made make-array fail on vectors of length between #x1000 and #x4000. --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/07 20:18:20 1.62 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/08 15:52:33 1.63 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.62 2007/04/07 20:18:20 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.63 2007/04/08 15:52:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -157,7 +157,7 @@ "Does the basic-vector have a fill-pointer?" `(with-inline-assembly (:returns :boolean-zf=1) (:compile-form (:result-mode :eax) ,vector) - (:testl ,(logxor #xffffffff (1- (expt 2 14))) + (:testl ,(logxor #xffffffff (* movitz:+movitz-fixnum-factor+ (1- (expt 2 14)))) (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))))) (define-compiler-macro %basic-vector-fill-pointer (vector) @@ -232,7 +232,8 @@ (:jnz 'illegal-fill-pointer) (:movl (:ebx (:offset movitz-basic-vector num-elements)) :ecx) - (:testl ,(logxor #xffffffff (1- (expt 2 14))) :ecx) + (:testl ,(logxor #xffffffff (* movitz:+movitz-fixnum-factor+ (1- (expt 2 14)))) + :ecx) (:jnz '(:sub-program () (:compile-form (:result-mode :ignore) (error "Vector has no fill-pointer.")))) @@ -1099,6 +1100,7 @@ (do-it)))) (cond ((integerp fill-pointer) + (warn "sfp len: ~s" (array-dimension array 0)) (setf (fill-pointer array) fill-pointer)) ((or (eq t fill-pointer) (array-has-fill-pointer-p array))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 08 Apr '07

08 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv27055 Modified Files: ratios.lisp Log Message: Add some silly and slow cos and sin functions. --- /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2007/03/16 19:49:24 1.9 +++ /project/movitz/cvsroot/movitz/losp/muerte/ratios.lisp 2007/04/08 13:44:44 1.10 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 20 00:39:59 2004 ;;;; -;;;; $Id: ratios.lisp,v 1.9 2007/03/16 19:49:24 ffjeld Exp $ +;;;; $Id: ratios.lisp,v 1.10 2007/04/08 13:44:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -76,9 +76,28 @@ (integer 1) (ratio (%ratio-denominator x)))) -(defconstant pi #xea7632a/4aa1a8b) - (defconstant least-positive-short-float 1/1000) (defconstant least-positive-single-float 1/1000) (defconstant least-positive-double-float 1/1000) (defconstant least-positive-long-float 1/1000) + +;;; + +(defconstant pi #xea7632a/4aa1a8b) + +(defvar long-float-epsilon 1/10000) + +(defun cos (x) + "http://mathworld.wolfram.com/Cosine.html" + (do* ((rad (mod x 44/7)) + (n2 0 (+ n2 2)) + (sign 1 (- sign)) + (denominator 1 (* denominator (1- n2) n2)) + (term 1 (/ (expt rad n2) + denominator)) + (sum 1 (+ sum (* sign term)))) + ((<= term long-float-epsilon) + sum))) + +(defun sin (x) + (cos (- x (/ pi 2))))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 08 Apr '07

08 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv22352 Modified Files: format.lisp Log Message: Format-float was completely broken: It tried to round off when printing the last digit, but that must be done initially, in case of "overflow". --- /project/movitz/cvsroot/movitz/losp/muerte/format.lisp 2007/02/11 21:57:14 1.15 +++ /project/movitz/cvsroot/movitz/losp/muerte/format.lisp 2007/04/08 13:14:58 1.16 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Mar 23 01:18:36 2002 ;;;; -;;;; $Id: format.lisp,v 1.15 2007/02/11 21:57:14 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.16 2007/04/08 13:14:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -68,24 +68,22 @@ ((minusp x) (write-char #\-) (format-float (- x) at-sign-p colon-p w d k overflowchar padchar)) - (t (multiple-value-bind (integer-part decimal-part) - (truncate x) - (write-integer integer-part *standard-output* 10 nil) - (dotimes (i k) - (write-char #\0)) - (write-char #\.) - (do ((remainder decimal-part) - (last-i (if d (1- d) 15)) - (i 0 (1+ i))) - ((or (and (not d) (plusp i) (zerop remainder)) - (> i last-i))) - (declare (index i)) - (multiple-value-bind (next-digit next-remainder) - (if (= i last-i) - (floor (+ 1/2 (* 10 remainder))) - (truncate (* 10 remainder))) - (setf remainder next-remainder) - (write-digit next-digit *standard-output*))))))) + (t (let ((decimals (if d (1- d) 15))) + (multiple-value-bind (integer-part decimal-part) + (truncate (+ x (* 1/20 (expt 1/10 decimals)))) + (write-integer integer-part *standard-output* 10 nil) + (dotimes (i k) + (write-char #\0)) + (write-char #\.) + (do ((remainder decimal-part) + (i 0 (1+ i))) + ((or (and (not d) (plusp i) (zerop remainder)) + (> i decimals))) + (declare (index i)) + (multiple-value-bind (next-digit next-remainder) + (truncate (* 10 remainder)) + (setf remainder next-remainder) + (write-digit next-digit *standard-output*)))))))) (defun find-directive (string i directive &optional recursive-skip-start (recursive-skip-end directive))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '07

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv31071 Modified Files: scavenge.lisp Log Message: Improved format-strings in map-header-vals. --- /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/04/05 21:12:19 1.60 +++ /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/04/07 20:50:38 1.61 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.60 2007/04/05 21:12:19 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.61 2007/04/07 20:50:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -67,7 +67,7 @@ (let ((x (memref scan 0 :type :unsigned-byte16)) (x2 (memref scan 2 :type :unsigned-byte16))) (when verbose - (format *terminal-io* " [at ~S: ~S]" scan x)) + (format *terminal-io* " [at #x~X: #x~X]" scan x)) (cond ((let ((tag (ldb (byte 3 0) x))) (or (= tag #.(movitz:tag :null)) @@ -78,10 +78,10 @@ (and (= #xffff x2) (= #xfffe x)) (and (= #x7fff x2) (= #xffff x)))) ((scavenge-typep x :illegal) - (error "Illegal word ~S at ~S." x scan)) + (error "Illegal word #x~4,'0X at #x~X." x scan)) ((scavenge-typep x :bignum) (assert (evenp scan) () - "Scanned bignum-header ~S at odd location #x~X." x scan) + "Scanned bignum-header #x~4,'0X at odd location #x~X." x scan) ;; Just skip the bigits (let* ((bigits (memref scan 0 :index 1 :type :unsigned-byte14)) (delta (logior bigits 1))) @@ -89,11 +89,11 @@ (incf scan delta))) ((scavenge-typep x :defstruct) (assert (evenp scan) () - "Scanned struct-header ~S at odd location #x~X." x scan) + "Scanned struct-header #x~4,'0X at odd location #x~X." x scan) (record-scan (%word-offset scan #.(movitz:tag :other)))) ((scavenge-typep x :run-time-context) (assert (evenp scan) () - "Scanned run-time-context-header ~S at odd location #x~X." + "Scanned run-time-context-header #x~4,'0X at odd location #x~X." (memref scan 0 :type :unsigned-byte32) scan) (incf scan) (let ((non-lispvals #.(cl:truncate (cl:+ -4 (bt:slot-offset 'movitz::movitz-run-time-context @@ -106,7 +106,7 @@ (setf scan end))) ((scavenge-typep x :funobj) (assert (evenp scan) () - "Scanned funobj-header ~S at odd location #x~X." + "Scanned funobj-header #x~4,'0X at odd location #x~X." (memref scan 0 :type :unsigned-byte32) scan) (record-scan (%word-offset scan #.(movitz:tag :other))) ;; Process code-vector pointers specially.. @@ -157,11 +157,11 @@ (incf scan num-jumpers)))))) ((scavenge-typep x :infant-object) (assert (evenp scan) () - "Scanned infant ~S at odd location #x~X." x scan) - (error "Scanning an infant object ~Z at ~S (end ~S)." x scan end-location)) + "Scanned infant #x~4,'0X at odd location #x~X." x scan) + (error "Scanning an infant object #x~4,'0X at #x~X (end #x~X)." x scan end-location)) ((scavenge-typep x :basic-vector) (assert (evenp scan) () - "Scanned basic-vector-header ~S at odd location #x~X." x scan) + "Scanned basic-vector-header #x~4,'0X at odd location #x~X." x scan) (cond ((or (scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u8)) @@ -191,7 +191,7 @@ #.(bt:enum-value 'movitz:movitz-vector-element-type :indirects))) (record-scan (%word-offset scan #.(movitz:tag :other)))) - (t (error "Scanned unknown basic-vector-header ~S at location #x~X." x scan)))) + (t (error "Scanned unknown basic-vector-header #x~4,'0X at location #x~X." x scan)))) ((and (eq x 3) (eq x2 0)) (record-scan scan) (incf scan) @@ -202,9 +202,9 @@ (t ;; (typep x 'pointer) (let* ((old (memref scan 0)) (new (funcall function old scan))) - (when verbose - (format *terminal-io* " [~Z => ~Z]" old new)) (unless (eq old new) + (when verbose + (format *terminal-io* " [~Z => ~Z]" old new)) (setf (memref scan 0) new)))))))) (values))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '07

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv30506 Modified Files: interrupt.lisp Log Message: Improved error decoding for exception 69. --- /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2007/03/26 21:11:43 1.55 +++ /project/movitz/cvsroot/movitz/losp/muerte/interrupt.lisp 2007/04/07 20:49:17 1.56 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.55 2007/03/26 21:11:43 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.56 2007/04/07 20:49:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -342,10 +342,15 @@ $eip $eax $ebx $ecx $edx) (dotimes (i 100000) (with-inline-assembly (:returns :nothing) (:nop)))) - (69 (error 'type-error - :datum (dereference $eax) - :expected-type (aref #(cons function) - (dereference $ecx :unsigned-byte8)))) + (69 (let ((expected-type + (aref #(cons function) + (dereference $ecx :unsigned-byte8)))) + (error 'type-error + :datum (case expected-type + (function + (dereference $edx)) + (t (dereference $eax))) + :expected-type expected-type))) (70 (error "Unaligned memref access.")) ((5 55) (let* ((old-bottom (prog1 (%run-time-context-slot nil 'stack-bottom)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '07

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv25962 Modified Files: arrays.lisp Log Message: make-basic-vector%t used to have an atomic-sequence that was O(N) to the length of the vector. Consequently, with somewhat frequent interrupts and a slightly large N, this sequence would never reach completion. Lesson is, atomic sequences must be O(1). --- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/03/11 22:41:45 1.61 +++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp 2007/04/07 20:18:20 1.62 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.61 2007/03/11 22:41:45 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.62 2007/04/07 20:18:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1040,36 +1040,75 @@ (defun make-basic-vector%t (length fill-pointer initial-element initial-contents) (check-type length (and fixnum (integer 0 *))) - (let* ((words (+ 2 length)) - (array (macrolet - ((do-it () - `(with-allocation-assembly (words :fixed-size-p t - :object-register :eax) - (:load-lexical (:lexical-binding length) :ecx) - (:movl ,(movitz:basic-vector-type-tag :any-t) - (:eax (:offset movitz-basic-vector type))) - (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))) - (:addl 4 :ecx) - (:andl -8 :ecx) - (:jz 'init-done) - (:load-lexical (:lexical-binding initial-element) :edx) - init-loop - (:movl :edx (:eax (:offset movitz-basic-vector data) :ecx -4)) - (:subl 4 :ecx) - (:jnz 'init-loop) - init-done - ))) - (do-it)))) + (let* ((words (+ 2 length))) (cond - ((integerp fill-pointer) - (setf (fill-pointer array) fill-pointer)) - ((or (eq t fill-pointer) - (array-has-fill-pointer-p array)) - (setf (fill-pointer array) length))) - (cond - (initial-contents - (replace array initial-contents))) - array)) + ((<= length 8) + (let ((array (macrolet + ((do-it () + `(with-allocation-assembly (words :fixed-size-p t + :object-register :eax) + (:load-lexical (:lexical-binding length) :ecx) + (:movl ,(movitz:basic-vector-type-tag :any-t) + (:eax (:offset movitz-basic-vector type))) + (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))) + (:addl 4 :ecx) + (:andl -8 :ecx) + (:jz 'init-done) + (:load-lexical (:lexical-binding initial-element) :edx) + init-loop + (:movl :edx (:eax (:offset movitz-basic-vector data) :ecx -4)) + (:subl 4 :ecx) + (:jnz 'init-loop) + init-done + ))) + (do-it)))) + (cond + ((integerp fill-pointer) + (setf (fill-pointer array) fill-pointer)) + ((or (eq t fill-pointer) + (array-has-fill-pointer-p array)) + (setf (fill-pointer array) length))) + (when initial-contents + (replace array initial-contents)) + array)) + (t (let* ((init-word (if (typep initial-element '(or null fixnum character)) + initial-element + nil)) + (array (macrolet + ((do-it () + `(with-inline-assembly (:returns :eax) + (:compile-form (:result-mode :eax) + (with-non-pointer-allocation-assembly (words :fixed-size-p t + :object-register :eax) + (:load-lexical (:lexical-binding length) :ecx) + (:movl ,(movitz:basic-vector-type-tag :u32) + (:eax (:offset movitz-basic-vector type))) + (:movl :ecx (:eax (:offset movitz-basic-vector num-elements))))) + (:load-lexical (:lexical-binding length) :ecx) + (:addl 4 :ecx) + (:andl -8 :ecx) + (:jz 'init-done2) + (:load-lexical (:lexical-binding init-word) :edx) + init-loop2 + (:movl :edx (:eax (:offset movitz-basic-vector data) :ecx -4)) + (:subl 4 :ecx) + (:jnz 'init-loop2) + init-done2 + (:movl ,(movitz:basic-vector-type-tag :any-t) + (:eax (:offset movitz-basic-vector type)))))) + (do-it)))) + (cond + ((integerp fill-pointer) + (setf (fill-pointer array) fill-pointer)) + ((or (eq t fill-pointer) + (array-has-fill-pointer-p array)) + (setf (fill-pointer array) length))) + (cond + (initial-contents + (replace array initial-contents)) + ((not (eq init-word initial-element)) + (fill array initial-element))) + array))))) (defun make-indirect-vector (displaced-to displaced-offset fill-pointer length) (let ((x (make-basic-vector%t 4 0 nil nil)))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '07

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv25634 Modified Files: sequences.lisp Log Message: Fix nsubstitute-if for :from-end t. Previously it could spin eternally. --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/04/07 07:59:31 1.36 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/04/07 20:14:45 1.37 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.36 2007/04/07 07:59:31 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.37 2007/04/07 20:14:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1886,90 +1886,97 @@ (defun nsubstitute-if (newitem predicate sequence &key (start 0) end count (key 'identity) from-end) "=> sequence" - (with-funcallable (predicate) - (with-funcallable (key) - (sequence-dispatch sequence - (vector - (let ((end (or end (length sequence)))) - (with-subvector-accessor (ref sequence start end) - (cond - ((and (not count) (not from-end)) - (do ((i start (1+ i))) - ((>= i end) sequence) - (declare (index i)) - (when (predicate (key (ref i))) - (setf (ref i) newitem)))) - ((and count (not from-end)) - (do ((c 0) - (i start (1+ i))) - ((>= i end) sequence) - (declare (index i c)) - (when (predicate (key (ref i))) - (setf (ref i) newitem) - (when (>= (incf c) count) - (return sequence))))) - ((and (not count) from-end) - (do ((i (1- end) (1- i))) - ((< i start) sequence) - (declare (index i)) - (when (predicate (key (ref i))) - (setf (ref i) newitem)))) - ((and count from-end) - (do ((c 0) - (i (1- end) (1- i))) - ((< i start) sequence) - (declare (index c i)) - (when (predicate (key (ref i))) - (setf (ref i) newitem) - (when (>= (incf c) count) - (return sequence))))) - ((error 'program-error)))))) - (list - (let ((p (nthcdr start sequence))) - (if (and from-end count) - (let* ((end (and end (- end start))) - (existing-count (count-if predicate p :key key :end end))) - (do ((i count)) - ((>= i existing-count) - (nsubstitute-if newitem predicate p :end end :key key) - sequence) - (declare (index i)) - (when (predicate (key (car p))) - (incf i)) - (setf p (cdr p)))) - (cond - ((and (not end) (not count)) - (do ((p p (cdr p))) - ((endp p) sequence) - (when (predicate (key (car p))) - (setf (car p) newitem)))) - ((and end (not count)) - (do ((i start (1+ i)) - (p p (cdr p))) - ((or (endp p) (>= i end)) sequence) - (declare (index i)) - (when (predicate (key (car p))) - (setf (car p) newitem)))) - ((and (not end) count) - (do ((c 0) - (p p (cdr p))) - ((endp p) sequence) - (declare (index c)) - (when (predicate (key (car p))) - (setf (car p) newitem) - (when (>= (incf c) count) - (return sequence))))) - ((and end count) - (do ((c 0) - (i start (1+ i)) - (p p (cdr p))) - ((or (endp p) (>= i end)) sequence) - (declare (index c i)) - (when (predicate (key (car p))) - (setf (car p) newitem) - (when (>= (incf c) count) - (return sequence))))) - ((error 'program-error)))))))))) + (if (<= count 0) + sequence + (with-funcallable (predicate) + (with-funcallable (key) + (sequence-dispatch sequence + (vector + (let ((end (or end (length sequence)))) + (with-subvector-accessor (ref sequence start end) + (cond + ((and (not count) (not from-end)) + (do ((i start (1+ i))) + ((>= i end) sequence) + (declare (index i)) + (when (predicate (key (ref i))) + (setf (ref i) newitem)))) + ((and count (not from-end)) + (do ((c 0) + (i start (1+ i))) + ((>= i end) sequence) + (declare (index i c)) + (when (predicate (key (ref i))) + (setf (ref i) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((and (not count) from-end) + (do ((i (1- end) (1- i))) + ((< i start) sequence) + (declare (index i)) + (when (predicate (key (ref i))) + (setf (ref i) newitem)))) + ((and count from-end) + (do ((c 0) + (i (1- end) (1- i))) + ((< i start) sequence) + (declare (index c i)) + (when (predicate (key (ref i))) + (setf (ref i) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((error 'program-error)))))) + (list + (let ((p (nthcdr start sequence))) + (cond + (from-end + (nreverse (nsubstitute-if newitem predicate (nreverse sequence) + :start (if (not end) 0 (- (length sequence) end)) + :end (if (plusp start) nil (- (length sequence) start)) + :count count :key key))) + #+ignore ((and from-end count) + (let* ((end (and end (- end start))) + (existing-count (count-if predicate p :key key :end end))) + (do ((i count)) + ((>= i existing-count) + (nsubstitute-if newitem predicate p :end end :key key) + sequence) + (declare (index i)) + (when (predicate (key (car p))) + (incf i)) + (setf p (cdr p))))) + ((and (not end) (not count)) + (do ((p p (cdr p))) + ((endp p) sequence) + (when (predicate (key (car p))) + (setf (car p) newitem)))) + ((and end (not count)) + (do ((i start (1+ i)) + (p p (cdr p))) + ((or (endp p) (>= i end)) sequence) + (declare (index i)) + (when (predicate (key (car p))) + (setf (car p) newitem)))) + ((and (not end) count) + (do ((c 0) + (p p (cdr p))) + ((endp p) sequence) + (declare (index c)) + (when (predicate (key (car p))) + (setf (car p) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((and end count) + (do ((c 0) + (i start (1+ i)) + (p p (cdr p))) + ((or (endp p) (>= i end)) sequence) + (declare (index c i)) + (when (predicate (key (car p))) + (setf (car p) newitem) + (when (>= (incf c) count) + (return sequence))))) + ((error 'program-error)))))))))) (defun nsubstitute-if-not (newitem predicate sequence &rest keyargs) (declare (dynamic-extent keyargs))

1 0

[movitz-cvs] CVS movitz/losp/x86-pc
by ffjeld 07 Apr '07

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv26637 Modified Files: vga.lisp Log Message: Indentation. --- /project/movitz/cvsroot/movitz/losp/x86-pc/vga.lisp 2007/03/26 18:04:04 1.12 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/vga.lisp 2007/04/07 08:04:51 1.13 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 25 14:08:20 2001 ;;;; -;;;; $Id: vga.lisp,v 1.12 2007/03/26 18:04:04 ffjeld Exp $ +;;;; $Id: vga.lisp,v 1.13 2007/04/07 08:04:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -106,131 +106,131 @@ ;;; 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))) + '((: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))) + '((: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))) + '((: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))) + '((: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))) + '((: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))) + '((: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-state-320x200x256-modex+ - '((:misc . #x63) - (:sequencer - #x03 #x01 #x0F #x00 #x06) - (:crtc - #x5F #x4F #x50 #x82 #x54 #x80 #xBF #x1F - #x00 #x41 #x00 #x00 #x00 #x00 #x00 #x00 - #x9C #x0E #x8F #x28 #x00 #x96 #xB9 #xE3 - #xFF) - (:graphics - #x00 #x00 #x00 #x00 #x00 #x40 #x05 #x0F - #xFF) - (:attribute - #x00 #x01 #x02 #x03 #x04 #x05 #x06 #x07 - #x08 #x09 #x0A #x0B #x0C #x0D #x0E #x0F - #x41 #x00 #x0F #x00 #x00))) + '((:misc . #x63) + (:sequencer + #x03 #x01 #x0F #x00 #x06) + (:crtc + #x5F #x4F #x50 #x82 #x54 #x80 #xBF #x1F + #x00 #x41 #x00 #x00 #x00 #x00 #x00 #x00 + #x9C #x0E #x8F #x28 #x00 #x96 #xB9 #xE3 + #xFF) + (:graphics + #x00 #x00 #x00 #x00 #x00 #x40 #x05 #x0F + #xFF) + (:attribute + #x00 #x01 #x02 #x03 #x04 #x05 #x06 #x07 + #x08 #x09 #x0A #x0B #x0C #x0D #x0E #x0F + #x41 #x00 #x0F #x00 #x00))) ;; intended future wrapper for graphics modes (defconstant +graphical-mode-modex+ - '(+vga-state-320x200x256-modex+ ; vga state - 320 ; width - 200 ; height - 3)) ; page count + '(+vga-state-320x200x256-modex+ ; vga state + 320 ; width + 200 ; height + 3)) ; page count (defvar *vga-current-page* 0) @@ -294,40 +294,40 @@ (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)) + (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) @@ -411,647 +411,647 @@ (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 [1230 lines skipped]

1 0

[movitz-cvs] CVS movitz/losp/x86-pc
by ffjeld 07 Apr '07

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory clnet:/tmp/cvs-serv26544 Modified Files: pci.lisp Log Message: For scan-pci-bus, make bus 0 the default. --- /project/movitz/cvsroot/movitz/losp/x86-pc/pci.lisp 2005/08/24 07:33:21 1.12 +++ /project/movitz/cvsroot/movitz/losp/x86-pc/pci.lisp 2007/04/07 08:03:03 1.13 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Dec 14 22:33:42 2003 ;;;; -;;;; $Id: pci.lisp,v 1.12 2005/08/24 07:33:21 ffjeld Exp $ +;;;; $Id: pci.lisp,v 1.13 2007/04/07 08:03:03 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -308,7 +308,7 @@ (t (list (pop mem-keys) (logand base -16)))))) -(defun scan-pci-bus (bus) +(defun scan-pci-bus (&optional (bus 0)) (loop for device from 0 to 31 do (multiple-value-bind (vendor-id return-code) (pci-bios-config-space-word bus device 0 0)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '07

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26494 Modified Files: symbols.lisp Log Message: Add gentemp. --- /project/movitz/cvsroot/movitz/losp/muerte/symbols.lisp 2007/02/22 22:11:21 1.28 +++ /project/movitz/cvsroot/movitz/losp/muerte/symbols.lisp 2007/04/07 08:02:35 1.29 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.28 2007/02/22 22:11:21 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.29 2007/04/07 08:02:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -246,6 +246,14 @@ (make-symbol (format nil "~A~D" x (prog1 *gensym-counter* (incf *gensym-counter*))))))) +(defvar *gentemp-counter* 0) + +(defun gentemp (&optional (prefix "T") (package *package*)) + (intern (do ((name #0=(format nil "~A~D" prefix *gentemp-counter*) #0#)) + ((not (find-symbol name package)) name) + (incf *gentemp-counter*)) + package)) + (defun get (symbol indicator &optional default) (getf (symbol-plist symbol) indicator default))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '07

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv26392 Modified Files: inspect.lisp Log Message: Add a recursion limit to objects-equalp. --- /project/movitz/cvsroot/movitz/losp/muerte/inspect.lisp 2007/03/16 19:50:47 1.58 +++ /project/movitz/cvsroot/movitz/losp/muerte/inspect.lisp 2007/04/07 08:01:41 1.59 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.58 2007/03/16 19:50:47 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.59 2007/04/07 08:01:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -268,22 +268,24 @@ (run-time-context (%shallow-copy-object old (movitz-type-word-size 'movitz-run-time-context))))) -(defun objects-equalp (x y) +(defun objects-equalp (x y &optional (limit 20)) "Basically, this verifies whether x is a shallow-copy of y, or vice versa." (assert (not (with-inline-assembly (:returns :boolean-zf=1) (:load-lexical (:lexical-binding x) :eax) (:cmpl #x13 :eax))) (x) "Checking illegal ~S for object-equalp." x) - (or (eql x y) + (or (= 0 (decf limit)) + (eql x y) (cond - ((not (objects-equalp (class-of x) (class-of y))) + ((not (objects-equalp (class-of x) (class-of y) limit)) nil) ((not (and (typep x 'pointer) (typep y 'pointer))) nil) (t (macrolet ((test (accessor &rest args) `(objects-equalp (,accessor x ,@args) - (,accessor y ,@args)))) + (,accessor y ,@args) + limit))) (typecase x (bignum (= x y))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '07

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24550 Modified Files: sequences.lisp Log Message: Fix a rather nasty bug in reduce when :end nil was specified for a vector sequence: The length never got computed and the vector would be accessed out of bounds (and so cause all sorts of strange effects). --- /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/03/21 20:20:33 1.35 +++ /project/movitz/cvsroot/movitz/losp/muerte/sequences.lisp 2007/04/07 07:59:31 1.36 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 11 14:19:23 2001 ;;;; -;;;; $Id: sequences.lisp,v 1.35 2007/03/21 20:20:33 ffjeld Exp $ +;;;; $Id: sequences.lisp,v 1.36 2007/04/07 07:59:31 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -124,57 +124,75 @@ ((= index end) result) (declare (index index))))))))))) (t (function sequence &key (key 'identity) from-end - (start 0) (end (length sequence)) + (start 0) end (initial-value nil initial-value-p)) (let ((start (check-the index start))) (with-funcallable (funcall-function function) (with-funcallable (key) - (case (- end start) - (0 (if initial-value-p - initial-value - (funcall-function))) - (1 (if initial-value-p - (funcall-function initial-value (key (elt sequence start))) - (key (elt sequence start)))) - (t (sequence-dispatch sequence - (list - (cond - ((not from-end) - (do* ((counter (1+ start) (1+ counter)) - (list (nthcdr start sequence)) - (result (funcall-function (if initial-value-p - initial-value - (key (pop list))) - (key (pop list))) - (funcall-function result (key (pop list))))) - ((or (null list) - (= end counter)) - result) - (declare (index counter)))) - (from-end - (do* ((counter (1+ start) (1+ counter)) - (list (nreverse (subseq sequence start end))) - (result (funcall-function (key (pop list)) - (if initial-value-p - initial-value - (key (pop list)))) - (funcall-function (key (pop list)) result))) - ((or (null list) - (= end counter)) - result) - (declare (index counter)))))) - (vector - (when from-end - (error "REDUCE from-end on vectors is not implemented.")) - (with-subvector-accessor (sequence-ref sequence start end) - (do* ((index start) - (result (funcall-function (if initial-value-p - initial-value - (key (sequence-ref (prog1 index (incf index))))) - (key (sequence-ref (prog1 index (incf index))))) - (funcall-function result (sequence-ref (prog1 index (incf index)))))) - ((= index end) result) - (declare (index index)))))))))))))) + (sequence-dispatch sequence + (list + (let ((list (nthcdr start sequence))) + (cond + ((null list) + (if initial-value-p + initial-value + (funcall-function))) + ((null (cdr list)) + (if initial-value-p + (funcall-function initial-value (key (car list))) + (key (car list)))) + ((not from-end) + (if (not end) + (do ((result (funcall-function (if initial-value-p + initial-value + (key (pop list))) + (key (pop list))) + (funcall-function result (key (pop list))))) + ((null list) result)) + (do ((counter (1+ start) (1+ counter)) + (result (funcall-function (if initial-value-p + initial-value + (key (pop list))) + (key (pop list))) + (funcall-function result (key (pop list))))) + ((or (null list) + (= end counter)) + result) + (declare (index counter))))) + (from-end + (do* ((end (or end (+ start (length list)))) + (counter (1+ start) (1+ counter)) + (list (nreverse (subseq sequence start end))) + (result (funcall-function (key (pop list)) + (if initial-value-p + initial-value + (key (pop list)))) + (funcall-function (key (pop list)) result))) + ((or (null list) + (= end counter)) + result) + (declare (index counter))))))) + (vector + (when from-end + (error "REDUCE from-end on vectors is not implemented.")) + (let ((end (or (check-the index end) + (length sequence)))) + (case (- end start) + (0 (if initial-value-p + initial-value + (funcall-function))) + (1 (if initial-value-p + (funcall-function initial-value (key (elt sequence start))) + (key (elt sequence start)))) + (t (with-subvector-accessor (sequence-ref sequence start end) + (do* ((index start) + (result (funcall-function (if initial-value-p + initial-value + (key (sequence-ref (prog1 index (incf index))))) + (key (sequence-ref (prog1 index (incf index))))) + (funcall-function result (sequence-ref (prog1 index (incf index)))))) + ((= index end) result) + (declare (index index))))))))))))))) (defun subseq (sequence start &optional end) (sequence-dispatch sequence @@ -1569,6 +1587,25 @@ (right (1- end)) left-item right-item) (declare (index left right)) + ;; do median-of-three.. + (let ((p1 (vector-ref start)) + (p2 (vector-ref (+ start cut-off -1))) + (p3 (vector-ref (1- end)))) + (let ((kp1 (key p1)) + (kp2 (key p2)) + (kp3 (key p3))) + (cond + ((predicate p1 p2) + (if (predicate p2 p3) + (setf pivot p2 keyed-pivot kp2) + (if (predicate p1 p3) + (setf pivot p3 keyed-pivot kp3) + (setf pivot p1 keyed-pivot kp1)))) + ((predicate p2 p3) + (if (predicate p1 p3) + (setf pivot p1 keyed-pivot kp1) + (setf pivot p3 keyed-pivot kp3))) + (t (setf pivot p2 keyed-pivot kp2))))) partitioning-loop (do-while (not (predicate keyed-pivot (key (setf left-item (vector-ref left))))) (incf left) @@ -1586,8 +1623,10 @@ partitioning-complete (setf (vector-ref start) right-item ; (aref vector right) (vector-ref right) pivot) - (quick-sort vector predicate key start right cut-off) - (quick-sort vector predicate key (1+ right) end cut-off)))))))) + (when (and (> cut-off (- right start)) + (> cut-off (- end right))) + (quick-sort vector predicate key start right cut-off) + (quick-sort vector predicate key (1+ right) end cut-off))))))))) vector) (defun sort (sequence predicate &key (key 'identity))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 07 Apr '07

07 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv24391 Modified Files: integers.lisp Log Message: Fix bug that would return nil from (- nil 0) rather than err. --- /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2006/05/02 20:02:09 1.122 +++ /project/movitz/cvsroot/movitz/losp/muerte/integers.lisp 2007/04/07 07:56:45 1.123 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.122 2006/05/02 20:02:09 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.123 2007/04/07 07:56:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -622,7 +622,7 @@ (macrolet ((do-it () `(number-double-dispatch (minuend subtrahend) - ((t (eql 0)) + ((number (eql 0)) minuend) (((eql 0) t) (- subtrahend))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 05 Apr '07

05 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv29180 Modified Files: scavenge.lisp Log Message: In map-header-vals fix scanning of not-entirely-initialized funobjs. Add map-header-vals*, mostly as a debugging tool. --- /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/03/16 22:13:55 1.59 +++ /project/movitz/cvsroot/movitz/losp/muerte/scavenge.lisp 2007/04/05 21:12:19 1.60 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.59 2007/03/16 22:13:55 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.60 2007/04/05 21:12:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -40,6 +40,11 @@ (unless (eq object new-object) (setf (memref location 0) new-object))))))) +(defun map-header-vals* (function &optional (vector (%run-time-context-slot nil 'nursery-space))) + (check-type vector (vector (unsigned-byte 32))) + (let ((location (+ 2 (object-location vector)))) + (map-header-vals function location (+ location (length vector))))) + (defun map-header-vals (function start-location end-location) "Map function over each potential pointer word between start-location and end-location." @@ -106,7 +111,9 @@ (record-scan (%word-offset scan #.(movitz:tag :other))) ;; Process code-vector pointers specially.. (let* ((old-code-vector (memref (incf scan) 0 :type :code-vector)) - (new-code-vector (map-instruction-pointer function scan old-code-vector))) + (new-code-vector (if (eq 0 old-code-vector) + 0 ; i.e. a non-initialized funobj. + (map-instruction-pointer function scan old-code-vector)))) (cond ((not (eq new-code-vector old-code-vector)) ;; Code-vector%1op

1 0

[movitz-cvs] CVS movitz
by ffjeld 05 Apr '07

05 Apr '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv29011 Modified Files: compiler.lisp Log Message: Fix a bug in code for initializing a stack-allocated funobj: The initial code-vector slot should be 2 rather than 0 in order to be GC-safe. --- /project/movitz/cvsroot/movitz/compiler.lisp 2007/03/21 19:57:52 1.185 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2007/04/05 21:10:39 1.186 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.185 2007/03/21 19:57:52 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.186 2007/04/05 21:10:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -7417,7 +7417,7 @@ (:pushl 0) ; %3op (:pushl 0) ; %2op (:pushl 0) ; %1op - (:pushl 0) ; (default) + (:pushl 2) ; (default) 2 is recognized by map-header-vals as non-initialized funobj. (:pushl (:eax ,(slot-offset 'movitz-funobj 'type))) (:leal (:esp ,(tag :other)) :ebx)

1 0

[movitz-cvs] CVS movitz
by ffjeld 02 Apr '07

02 Apr '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv29414 Modified Files: special-operators-cl.lisp Log Message: For the block special operator, we need to ensure that the body-code resets the stack-pointer (which it won't, for result-mode :function). This fixes a hard crash on ansi-test assoc.25. --- /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2007/03/19 21:09:26 1.51 +++ /project/movitz/cvsroot/movitz/special-operators-cl.lisp 2007/04/02 20:54:34 1.52 @@ -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.51 2007/03/19 21:09:26 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.52 2007/04/02 20:54:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -860,7 +860,9 @@ (compiler-values-bind (&code block-code &functional-p block-no-side-effects-p) (compiler-call #'compile-form :defaults forward - :result-mode block-result-mode + :result-mode (case block-result-mode + (:function :multiple-values) ; must restore stack + (t block-result-mode)) :form `(muerte.cl:progn ,@body) :env block-env) (let ((label-set-name (gensym "block-label-set-"))

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 01 Apr '07

01 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv12646 Modified Files: arithmetic-macros.lisp Log Message: Removed useless check-type in * compiler-macro. --- /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2007/04/01 19:05:07 1.18 +++ /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2007/04/01 19:22:22 1.19 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Jul 17 13:42:46 2004 ;;;; -;;;; $Id: arithmetic-macros.lisp,v 1.18 2007/04/01 19:05:07 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.19 2007/04/01 19:22:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -257,7 +257,6 @@ `(* ,(movitz:movitz-eval factor2 env) ,factor1)) ((movitz:movitz-constantp factor1 env) (let ((f1 (movitz:movitz-eval factor1 env))) - (check-type f1 integer) (case f1 (0 `(progn ,factor2 0)) (1 factor2)

1 0

[movitz-cvs] CVS movitz/losp/muerte
by ffjeld 01 Apr '07

01 Apr '07

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv9951 Modified Files: arithmetic-macros.lisp Log Message: Remove unreachable code. --- /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2007/03/20 22:40:41 1.17 +++ /project/movitz/cvsroot/movitz/losp/muerte/arithmetic-macros.lisp 2007/04/01 19:05:07 1.18 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Jul 17 13:42:46 2004 ;;;; -;;;; $Id: arithmetic-macros.lisp,v 1.17 2007/03/20 22:40:41 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.18 2007/04/01 19:05:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -43,9 +43,7 @@ (:testb 1 :cl))) (define-compiler-macro + (&whole form &rest operands &environment env) - (flet ((term (x) (if (and nil (symbolp x)) - (gensym (format nil "term-~A-" x)) - (gensym "term-")))) + (flet ((term (x) (gensym "term-"))) (case (length operands) (0 0) (1 (first operands))

1 0

[movitz-cvs] CVS movitz
by ffjeld 01 Apr '07

01 Apr '07

Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv32157 Modified Files: image.lisp Log Message: Remove useless assertion. --- /project/movitz/cvsroot/movitz/image.lisp 2007/03/16 17:40:43 1.112 +++ /project/movitz/cvsroot/movitz/image.lisp 2007/04/01 18:18:26 1.113 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.112 2007/03/16 17:40:43 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.113 2007/04/01 18:18:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,10 +28,7 @@ (raw-scratch0 ; A non-GC-root scratch register :binary-type lu32 :initform 0) - - (pointer-start :binary-type :label) - (ret-trampoline :binary-type code-vector-word :map-binary-write 'movitz-intern-code-vector @@ -836,7 +833,6 @@ (or (ignore-errors (file-position stream position)) (let* ((end (file-position stream :end)) (diff (- position end))) - (assert (< 0 diff 10000)) (dotimes (i diff) (write-byte 0 stream)) (assert (= position (file-position stream)))))

1 0