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

[movitz-cvs] CVS update: movitz/losp/muerte/hash-tables.lisp
by Frode Vatvedt Fjeld 11 Oct '04

11 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30623 Modified Files: hash-tables.lisp Log Message: Changed the signature of memref and (setf memref) to use keywords also for the index and type arguments. Date: Mon Oct 11 15:52:38 2004 Author: ffjeld Index: movitz/losp/muerte/hash-tables.lisp diff -u movitz/losp/muerte/hash-tables.lisp:1.3 movitz/losp/muerte/hash-tables.lisp:1.4 --- movitz/losp/muerte/hash-tables.lisp:1.3 Wed Jun 30 01:19:21 2004 +++ movitz/losp/muerte/hash-tables.lisp Mon Oct 11 15:52:37 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Feb 19 19:09:05 2001 ;;;; -;;;; $Id: hash-tables.lisp,v 1.3 2004/06/29 23:19:21 ffjeld Exp $ +;;;; $Id: hash-tables.lisp,v 1.4 2004/10/11 13:52:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -96,9 +96,6 @@ (if (not (plusp limit)) 0 (typecase object - #+ignore - (std-instance - (memref object #x1e 2 :lisp)) (cons (logxor (sxhash-limited (car object) (- limit 2)) (sxhash-limited (cdr object) (1- limit))))

1 0

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

11 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30595 Modified Files: functions.lisp Log Message: Changed the signature of memref and (setf memref) to use keywords also for the index and type arguments. Date: Mon Oct 11 15:52:35 2004 Author: ffjeld Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.21 movitz/losp/muerte/functions.lisp:1.22 --- movitz/losp/muerte/functions.lisp:1.21 Wed Sep 22 18:40:32 2004 +++ movitz/losp/muerte/functions.lisp Mon Oct 11 15:52:34 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.21 2004/09/22 16:40:32 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.22 2004/10/11 13:52:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -106,12 +106,14 @@ (defun funobj-code-vector (funobj) (check-type funobj function) - (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :code-vector)) + (memref funobj (movitz-type-slot-offset 'movitz-funobj 'code-vector) + :type :code-vector)) (defun (setf funobj-code-vector) (code-vector funobj) (check-type funobj function) (check-type code-vector code-vector) - (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::code-vector) 0 :code-vector) + (setf (memref funobj (movitz-type-slot-offset 'movitz-funobj 'code-vector) + :type :code-vector) code-vector)) (defun funobj-code-vector%1op (funobj) @@ -299,12 +301,12 @@ (defun funobj-name (funobj) (check-type funobj function) - (movitz-accessor funobj movitz-funobj name)) + (memref funobj (movitz-type-slot-offset 'movitz-funobj 'name))) (defun (setf funobj-name) (name funobj) (check-type funobj function) - ;; (check-type name (or symbol list) - (setf-movitz-accessor (funobj movitz-funobj name) name)) + (setf (memref funobj (movitz-type-slot-offset 'movitz-funobj 'name)) + name)) (defun funobj-lambda-list (funobj) (check-type funobj function) @@ -342,7 +344,7 @@ (assert (below index (funobj-num-constants funobj)) (index) "Index ~D out of range, ~S has ~D constants." index funobj (funobj-num-constants funobj)) (if (>= index (funobj-num-jumpers funobj)) - (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0) index :lisp) + (memref funobj (movitz-type-slot-offset 'movitz-funobj 'constant0) :index index) ;; For a jumper, return its offset relative to the code-vector. ;; This is tricky wrt. to potential GC interrupts, because we're doing ;; pointer arithmetics. @@ -361,8 +363,7 @@ (assert (below index (funobj-num-constants funobj)) (index) "Index ~D out of range, ~S has ~D constants." index funobj (funobj-num-constants funobj)) (if (>= index (funobj-num-jumpers funobj)) - (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0) - index :lisp) + (setf (memref funobj (movitz-type-slot-offset 'movitz-funobj 'constant0) :index index) value) (progn (assert (below value (length (funobj-code-vector funobj))) (value) @@ -382,7 +383,7 @@ (defun funobj-debug-info (funobj) (check-type funobj function) - (movitz-accessor-u16 funobj movitz-funobj debug-info)) + (memref funobj (movitz-type-slot-offset 'movitz-funobj 'debug-info) :type :unsigned-byte16)) (defun funobj-frame-num-unboxed (funobj) "The number of unboxed slots in this function's stack-frame(s)."

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/defstruct.lisp
by Frode Vatvedt Fjeld 11 Oct '04

11 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30575 Modified Files: defstruct.lisp Log Message: Changed the signature of memref and (setf memref) to use keywords also for the index and type arguments. Date: Mon Oct 11 15:52:28 2004 Author: ffjeld Index: movitz/losp/muerte/defstruct.lisp diff -u movitz/losp/muerte/defstruct.lisp:1.14 movitz/losp/muerte/defstruct.lisp:1.15 --- movitz/losp/muerte/defstruct.lisp:1.14 Thu Sep 23 11:31:28 2004 +++ movitz/losp/muerte/defstruct.lisp Mon Oct 11 15:52:27 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jan 22 13:10:59 2001 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defstruct.lisp,v 1.14 2004/09/23 09:31:28 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.15 2004/10/11 13:52:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -21,10 +21,10 @@ (defun structure-object-length (object) (check-type object structure-object) - (memref object -4 0 :unsigned-byte14)) + (memref object -4 :type :unsigned-byte14)) (defun structure-object-class (x) - (memref x -6 1 :lisp)) + (memref x -6 :index 1)) (defun copy-structure (object) (%shallow-copy-object object (+ 2 (structure-object-length object))))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/bignums.lisp
by Frode Vatvedt Fjeld 11 Oct '04

11 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30543 Modified Files: bignums.lisp Log Message: Changed the signature of memref and (setf memref) to use keywords also for the index and type arguments. Date: Mon Oct 11 15:52:21 2004 Author: ffjeld Index: movitz/losp/muerte/bignums.lisp diff -u movitz/losp/muerte/bignums.lisp:1.11 movitz/losp/muerte/bignums.lisp:1.12 --- movitz/losp/muerte/bignums.lisp:1.11 Thu Sep 23 11:17:51 2004 +++ movitz/losp/muerte/bignums.lisp Mon Oct 11 15:52:21 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Jul 17 19:42:57 2004 ;;;; -;;;; $Id: bignums.lisp,v 1.11 2004/09/23 09:17:51 ffjeld Exp $ +;;;; $Id: bignums.lisp,v 1.12 2004/10/11 13:52:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -82,7 +82,7 @@ (defun print-bignum (x) (check-type x bignum) (dotimes (i (1+ (%bignum-bigits x))) - (format t "~8,'0X " (memref x -6 i :unsigned-byte32))) + (format t "~8,'0X " (memref x -6 :index i :type :unsigned-byte32))) (terpri) (values)) @@ -468,7 +468,8 @@ (defun bignum-set-zerof (bignum) (check-type bignum bignum) (dotimes (i (%bignum-bigits bignum)) - (setf (memref bignum -2 i :lisp) 0)) + (setf (memref bignum (movitz-type-slot-offset 'movitz-bignum 'bigit0) + :index i :type :unsigned-byte32) 0)) bignum) (defun %bignum= (x y)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp
by Frode Vatvedt Fjeld 11 Oct '04

11 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30521 Modified Files: basic-macros.lisp Log Message: Changed the signature of memref and (setf memref) to use keywords also for the index and type arguments. Date: Mon Oct 11 15:52:18 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.41 movitz/losp/muerte/basic-macros.lisp:1.42 --- movitz/losp/muerte/basic-macros.lisp:1.41 Wed Sep 22 18:26:14 2004 +++ movitz/losp/muerte/basic-macros.lisp Mon Oct 11 15:52:18 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.41 2004/09/22 16:26:14 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.42 2004/10/11 13:52:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -391,6 +391,13 @@ (find-symbol (string slot-name) :movitz)))) (:leal ((:ecx #.movitz::+movitz-fixnum-factor+) :edi ,(- (movitz::image-nil-word movitz::*image*))) :eax))) + +(define-compiler-macro movitz-type-slot-offset (type slot &environment env) + (if (not (and (movitz:movitz-constantp type env) + (movitz:movitz-constantp slot env))) + (error "Non-constant movitz-type-slot-offset call.") + (bt:slot-offset (intern (symbol-name (movitz:movitz-eval type env)) :movitz) + (intern (symbol-name (movitz:movitz-eval slot env)) :movitz)))) (define-compiler-macro not (x)

1 0

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

11 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30496 Modified Files: arrays.lisp Log Message: Changed the signature of memref and (setf memref) to use keywords also for the index and type arguments. Date: Mon Oct 11 15:52:12 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.44 movitz/losp/muerte/arrays.lisp:1.45 --- movitz/losp/muerte/arrays.lisp:1.44 Fri Sep 24 11:31:19 2004 +++ movitz/losp/muerte/arrays.lisp Mon Oct 11 15:52:12 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sun Feb 11 23:14:04 2001 ;;;; -;;;; $Id: arrays.lisp,v 1.44 2004/09/24 09:31:19 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.45 2004/10/11 13:52:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -22,8 +22,8 @@ (in-package muerte) (defun vector-element-type (object) - (memref object #.(bt:slot-offset 'movitz::movitz-basic-vector 'movitz::element-type) 0 - :unsigned-byte8)) + (memref object (movitz-type-slot-offset 'movitz-basic-vector 'element-type) + :type :unsigned-byte8)) (defmacro vector-double-dispatch ((s1 s2) &rest clauses) (flet ((make-double-dispatch-value (et1 et2) @@ -43,14 +43,13 @@ forms)))))) (define-compiler-macro vector-element-type (object) - `(memref ,object 0 - ,(bt:slot-offset 'movitz::movitz-basic-vector 'movitz::element-type) - :unsigned-byte8)) + `(memref ,object (movitz-type-slot-offset 'movitz-basic-vector 'element-type) + :type :unsigned-byte8)) (defun (setf vector-element-type) (numeric-element-type vector) (check-type vector vector) - (setf (memref vector #.(bt:slot-offset 'movitz::movitz-basic-vector 'movitz::element-type) 0 - :unsigned-byte8) + (setf (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'element-type) + :type :unsigned-byte8) numeric-element-type)) (defun array-element-type (array) @@ -114,15 +113,16 @@ (etypecase array ((simple-array * 1) (assert (zerop axis-number)) - (movitz-accessor array movitz-basic-vector num-elements)))) + (memref array (movitz-type-slot-offset 'movitz-basic-vector 'num-elements))))) (defun array-dimensions (array) (check-type array array) 1) (defun shrink-vector (vector new-size) - (setf-movitz-accessor (vector movitz-basic-vector num-elements) new-size) - vector) + (check-type vector vector) + (setf (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'num-elements)) + new-size)) (define-compiler-macro %basic-vector-has-fill-pointer-p (vector) "Does the basic-vector have a fill-pointer?" @@ -155,29 +155,21 @@ (defun copy-vector (vector) (check-type vector vector) - (ecase (vector-element-type vector) - (#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t) - (%shallow-copy-object - vector - (+ 2 (movitz-accessor vector movitz-basic-vector num-elements)))) - (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32) - (%shallow-copy-non-pointer-object - vector - (+ 2 (movitz-accessor vector movitz-basic-vector num-elements)))) - ((#.(bt:enum-value 'movitz::movitz-vector-element-type :character) - #.(bt:enum-value 'movitz::movitz-vector-element-type :u8) - #.(bt:enum-value 'movitz::movitz-vector-element-type :code)) - (%shallow-copy-non-pointer-object - vector - (+ 2 (truncate (+ 3 (movitz-accessor vector movitz-basic-vector num-elements)) 4)))) - (#.(bt:enum-value 'movitz::movitz-vector-element-type :u16) - (%shallow-copy-non-pointer-object - vector - (+ 2 (truncate (+ 1 (movitz-accessor vector movitz-basic-vector num-elements)) 2)))) - (#.(bt:enum-value 'movitz::movitz-vector-element-type :bit) - (%shallow-copy-non-pointer-object - vector - (+ 2 (truncate (+ 31 (movitz-accessor vector movitz-basic-vector num-elements)) 32)))))) + (let ((length (the fixnum + (memref vector (movitz-type-slot-offset 'movitz-basic-vector 'num-elements))))) + (ecase (vector-element-type vector) + (#.(bt:enum-value 'movitz::movitz-vector-element-type :any-t) + (%shallow-copy-object vector (+ 2 length))) + (#.(bt:enum-value 'movitz::movitz-vector-element-type :u32) + (%shallow-copy-non-pointer-object vector (+ 2 length))) + ((#.(bt:enum-value 'movitz::movitz-vector-element-type :character) + #.(bt:enum-value 'movitz::movitz-vector-element-type :u8) + #.(bt:enum-value 'movitz::movitz-vector-element-type :code)) + (%shallow-copy-non-pointer-object vector (+ 2 (truncate (+ 3 length) 4)))) + (#.(bt:enum-value 'movitz::movitz-vector-element-type :u16) + (%shallow-copy-non-pointer-object vector (+ 2 (truncate (+ 1 length) 2)))) + (#.(bt:enum-value 'movitz::movitz-vector-element-type :bit) + (%shallow-copy-non-pointer-object vector (+ 2 (truncate (+ 31 length) 32))))))) (defun (setf fill-pointer) (new-fill-pointer vector) (etypecase vector @@ -298,8 +290,7 @@ (error "Index ~D is beyond vector length ~D." index (memref array - ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements) - 0 :lisp))))) + (movitz-type-slot-offset 'movitz-basic-vector 'num-elements)))))) (:jmp (:esi (:ecx 4) 'basic-vector-dispatcher ,(bt:slot-offset 'movitz:movitz-funobj 'movitz::constant0))) @@ -454,10 +445,10 @@ ;;; simple-vector accessors (define-compiler-macro svref%unsafe (simple-vector index) - `(memref ,simple-vector 2 ,index :lisp)) + `(memref ,simple-vector 2 :index ,index)) (define-compiler-macro (setf svref%unsafe) (value simple-vector index) - `(setf (memref ,simple-vector 2 ,index :lisp) ,value)) + `(setf (memref ,simple-vector 2 :index ,index) ,value)) (defun svref%unsafe (simple-vector index) ;; (compiler-macro-call svref%unsafe simple-vector index)) @@ -522,16 +513,16 @@ (defun char (string index) (check-type string string) (assert (below index (array-dimension string 0))) - (memref string 2 index :character)) + (memref string 2 :index index :type :character)) (defun (setf char) (value string index) (assert (below index (array-dimension string 0))) - (setf (memref string 2 index :character) value)) + (setf (memref string 2 :index index :type :character) value)) (defun schar (string index) (check-type string string) (assert (below index (length string))) - (memref string 2 index :character)) + (memref string 2 :index index :type :character)) (defun (setf schar) (value string index) (check-type string string) @@ -539,13 +530,13 @@ (setf (aref string index) value)) (define-compiler-macro char%unsafe (string index) - `(memref ,string 2 ,index :character)) + `(memref ,string 2 :index ,index :type :character)) (defun char%unsafe (string index) (char%unsafe string index)) (define-compiler-macro (setf char%unsafe) (value string index) - `(setf (memref ,string 2 ,index :character) ,value)) + `(setf (memref ,string 2 :index ,index :type :character) ,value)) (defun (setf char%unsafe) (value string index) (setf (char%unsafe string index) value)) @@ -553,13 +544,13 @@ ;;; u8 accessors (define-compiler-macro u8ref%unsafe (vector index) - `(memref ,vector 2 ,index :unsigned-byte8)) + `(memref ,vector 2 :index ,index :type :unsigned-byte8)) (defun u8ref%unsafe (vector index) (u8ref%unsafe vector index)) (define-compiler-macro (setf u8ref%unsafe) (value vector index) - `(setf (memref ,vector 2 ,index :unsigned-byte8) ,value)) + `(setf (memref ,vector 2 :index ,index :type :unsigned-byte8) ,value)) (defun (setf u8ref%unsafe) (value vector index) (setf (u8ref%unsafe vector index) value)) @@ -567,7 +558,7 @@ ;;; u32 accessors (define-compiler-macro u32ref%unsafe (vector index) - `(memref ,vector 2 ,index :unsigned-byte32)) + `(memref ,vector 2 :index ,index :type :unsigned-byte32)) (defun u32ref%unsafe (vector index) (compiler-macro-call u32ref%unsafe vector index)) @@ -576,7 +567,7 @@ (let ((var (gensym "setf-u32ref-value-"))) ;; Use var so as to avoid re-boxing of the u32 value. `(let ((,var ,value)) - (setf (memref ,vector 2 ,index :unsigned-byte32) ,var) + (setf (memref ,vector 2 :index ,index :type :unsigned-byte32) ,var) ,var))) (defun (setf u32ref%unsafe) (value vector index)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/arithmetic-macros.lisp
by Frode Vatvedt Fjeld 11 Oct '04

11 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30474 Modified Files: arithmetic-macros.lisp Log Message: Changed the signature of memref and (setf memref) to use keywords also for the index and type arguments. Date: Mon Oct 11 15:52:05 2004 Author: ffjeld Index: movitz/losp/muerte/arithmetic-macros.lisp diff -u movitz/losp/muerte/arithmetic-macros.lisp:1.7 movitz/losp/muerte/arithmetic-macros.lisp:1.8 --- movitz/losp/muerte/arithmetic-macros.lisp:1.7 Tue Sep 21 15:09:40 2004 +++ movitz/losp/muerte/arithmetic-macros.lisp Mon Oct 11 15:52:04 2004 @@ -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.7 2004/09/21 13:09:40 ffjeld Exp $ +;;;; $Id: arithmetic-macros.lisp,v 1.8 2004/10/11 13:52:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -486,8 +486,8 @@ done)) (define-compiler-macro %ratio-numerator (x) - `(memref ,x ,(bt:slot-offset 'movitz::movitz-ratio 'movitz::numerator) 0 :lisp)) + `(memref ,x (movitz-type-slot-offset 'movitz-ratio 'numerator))) (define-compiler-macro %ratio-denominator (x) - `(memref ,x ,(bt:slot-offset 'movitz::movitz-ratio 'movitz::denominator) 0 :lisp)) + `(memref ,x (movitz-type-slot-offset 'movitz-ratio 'denominator)))

1 0

[movitz-cvs] CVS update: movitz/losp/lib/malloc-init.lisp
by Frode Vatvedt Fjeld 11 Oct '04

11 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/lib In directory common-lisp.net:/tmp/cvs-serv30448 Modified Files: malloc-init.lisp Log Message: Changed the signature of memref and (setf memref) to use keywords also for the index and type arguments. Date: Mon Oct 11 15:52:01 2004 Author: ffjeld Index: movitz/losp/lib/malloc-init.lisp diff -u movitz/losp/lib/malloc-init.lisp:1.5 movitz/losp/lib/malloc-init.lisp:1.6 --- movitz/losp/lib/malloc-init.lisp:1.5 Thu Jul 15 23:06:38 2004 +++ movitz/losp/lib/malloc-init.lisp Mon Oct 11 15:52:01 2004 @@ -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.5 2004/07/15 21:06:38 ffjeld Exp $ +;;;; $Id: malloc-init.lisp,v 1.6 2004/10/11 13:52:01 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -31,7 +31,7 @@ (muerte:malloc-initialize start-location end-location) (setf (cdar muerte::%memory-map%) end-location) (loop for x from kernel-end-location below start-location - do (setf (memref x 0 0 :unsigned-byte32) 0)) + do (setf (memref x 0 :type :unsigned-byte32) 0)) (values))

1 0

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

11 Oct '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv30427 Modified Files: los0.lisp Log Message: Changed the signature of memref and (setf memref) to use keywords also for the index and type arguments. Date: Mon Oct 11 15:51:56 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.22 movitz/losp/los0.lisp:1.23 --- movitz/losp/los0.lisp:1.22 Tue Sep 21 15:11:08 2004 +++ movitz/losp/los0.lisp Mon Oct 11 15:51:55 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.22 2004/09/21 13:11:08 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.23 2004/10/11 13:51:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -151,6 +151,31 @@ '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) @@ -384,7 +409,7 @@ (defun xplus (x) (typep x '(integer 0 *))) -(defstruct xxx +(defstruct (xxx :constructor (:constructor boa-make-xxx (x y z))) x y (z 'init-z)) (defun test-struct () @@ -1035,7 +1060,7 @@ (muerte::positive-bignum (let ((x (muerte::copy-bignum limit))) (dotimes (i (1- (muerte::%bignum-bigits x))) - (setf (memref x 2 i :unsigned-byte32) + (setf (memref x 2 :index i :type :unsigned-byte32) (muerte::read-time-stamp-counter))) (setf x (muerte::bignum-canonicalize x)) (loop while (>= x limit) @@ -1049,7 +1074,6 @@ (:ret))) (defun test-irq (&optional eax ebx ecx edx) - (setf (memref nil #x7f 20 :code-vector) (symbol-value 'test-irq-pf)) (multiple-value-bind (p1 p2) (with-inline-assembly (:returns :multiple-values) (:load-lexical (:lexical-binding eax) :eax) @@ -1078,18 +1102,30 @@ (1+ x))) (defparameter *timer-stack* nil) +(defparameter *timer-prevstack* nil) (defparameter *timer-esi* nil) (defparameter *timer-frame* #100()) +(defparameter *timer-base* 2) +(defparameter *timer-variation* 1000) + +(defun test-format (&optional timeout (x #xab)) + (let ((fasit (format nil "~2,'0X" x))) + (test-timer timeout) + (format t "~&Fasit: ~S" fasit) + (loop + (let ((x (format nil "~2,'0X" x))) + (assert (string= fasit x) () + "Failed tesT. Fasit: ~S, X: ~S" fasit x))))) (defun test-clc (&optional timeout) (test-timer timeout) (loop (funcall (find-symbol (string :test-clc) :clc)))) -(defun test-timer (&optional timeout) +(defun test-timer (&optional timeout (base *timer-base*) (variation *timer-variation*)) (setf (exception-handler 32) (lambda (exception-vector exception-frame) - (declare (ignore exception-vector #+ignore exception-frame)) + (declare (ignore exception-vector exception-frame)) ;;; (loop with f = *timer-frame* ;;; for o from 20 downto -36 by 4 as i upfrom 0 ;;; do (setf (aref f i) (memref exception-frame o 0 :lisp))) @@ -1102,14 +1138,13 @@ ;;; (vector-push funobj ts) ;;; (vector-push offset ts) ;;; (vector-push code-vector ts)))) - (muerte::cli) + ;; (muerte::cli) (pic8259-end-of-interrupt 0) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) (:shrl 2 :ecx) ((:gs-override) :addb 1 (:ecx 158)) ((:gs-override) :movb #x40 (:ecx 159))) - (setf *timer-esi* (muerte::dit-frame-ref nil exception-frame :esi :unsigned-byte32)) (do ((frame (stack-frame-uplink nil (current-stack-frame)) (stack-frame-uplink nil frame))) ((plusp frame)) @@ -1127,21 +1162,22 @@ x) nil (current-stack-frame)) - (setf *timer-stack* (muerte::copy-current-control-stack)) - (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+ - (pit8253-timer-count 0) (or timeout (+ 5 (random 2000)))) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) (:shrl 2 :ecx) - ((:gs-override) :movb #x20 (:ecx 159))) - (muerte::sti) - )) + ((:gs-override) :movb #x20 (:ecx 159))) + (setf *timer-prevstack* *timer-stack* + *timer-stack* (muerte::copy-current-control-stack)) + (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+ + (pit8253-timer-count 0) (or timeout (+ base (random variation)))) + + #+ignore (muerte::sti))) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) (:shrl 2 :ecx) ((:gs-override) :movw #x4646 (:ecx 158))) (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+ - (pit8253-timer-count 0) (or timeout (+ 10 (random 1000)))) + (pit8253-timer-count 0) (or timeout (+ base (random variation)))) (setf (pic8259-irq-mask) #xfffe) (pic8259-end-of-interrupt 0) (with-inline-assembly (:returns :nothing) (:sti)) @@ -1179,6 +1215,12 @@ (incf (memref-int muerte.x86-pc::*screen* 0 80 :unsigned-byte16 t))))) (incf (memref-int muerte.x86-pc::*screen* 0 160 :unsigned-byte16 t)))))) +(defun mumbojumbo () + (with-inline-assembly (:returns :multiple-values) + (:leave) + (:movl (:ebp -4) :esi) + (:break) + (:ret))) (defun genesis () (let ((extended-memsize 0)) @@ -1190,11 +1232,12 @@ (format t "Extended memory: ~D KB~%" extended-memsize) (idt-init) - (install-los0-consing :kb-size 500) #+ignore + (install-los0-consing :kb-size 500) (install-los0-consing :kb-size (max 100 (truncate (- extended-memsize 1024 2048) 2)))) (setf *debugger-function* #'los0-debugger) + (clos-bootstrap) (let ((*repl-readline-context* (make-readline-context :history-size 16)) #+ignore (*backtrace-stack-frame-barrier* (stack-frame-uplink (current-stack-frame))) #+ignore (*error-no-condition-for-debugger* t) @@ -1208,7 +1251,6 @@ ;; (muerte:asm :int 49) (setf *package* (find-package "INIT")) - (clos-bootstrap) (when muerte::*multiboot-data* (set-textmode +vga-state-90x30+)) @@ -1228,7 +1270,7 @@ (let ((* nil) (** nil) (*** nil) (/ nil) (// nil) (/// nil) (+ nil) (++ nil) (+++ nil)) - (format t "~&Movitz image Los0 build ~D [~Z]." *build-number* (cons 1 2)) + (format t "~&Movitz image Los0 build ~D." *build-number*) (loop (catch :top-level-repl ; If restarts don't work, you can throw this.. (with-simple-restart (abort "Abort to the top command level.")

1 0

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

11 Oct '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv30405 Modified Files: los0-gc.lisp Log Message: Changed the signature of memref and (setf memref) to use keywords also for the index and type arguments. Date: Mon Oct 11 15:51:52 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.41 movitz/losp/los0-gc.lisp:1.42 --- movitz/losp/los0-gc.lisp:1.41 Thu Oct 7 14:54:43 2004 +++ movitz/losp/los0-gc.lisp Mon Oct 11 15:51:52 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.41 2004/10/07 12:54:43 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.42 2004/10/11 13:51:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -29,7 +29,7 @@ "Make a space vector at a fixed location." (assert (evenp location)) (macrolet ((x (index) - `(memref location 0 ,index :unsigned-byte32))) + `(memref location 0 :index ,index :type :unsigned-byte32))) (setf (x 1) (* #.movitz:+movitz-fixnum-factor+ size) (x 0) #.(cl:dpb (bt:enum-value 'movitz:movitz-vector-element-type :u32) (cl:byte 8 8) @@ -38,10 +38,10 @@ (defmacro space-fresh-pointer (space) - `(memref ,space -6 2 :lisp)) + `(memref ,space -6 :index 2)) (defmacro space-other (space) - `(memref ,space -6 3 :lisp)) + `(memref ,space -6 :index 3)) (defun allocate-space (size &optional other-space) (let ((space (make-array size :element-type '(unsigned-byte 32)))) @@ -339,8 +339,8 @@ x) (t (or (and (eq (object-tag x) (ldb (byte 3 0) - (memref (object-location x) 0 0 :unsigned-byte8))) - (let ((forwarded-x (memref (object-location x) 0 0 :lisp))) + (memref (object-location x) 0 :type :unsigned-byte8))) + (let ((forwarded-x (memref (object-location x) 0))) (and (object-in-space-p newspace forwarded-x) forwarded-x))) (let ((forward-x (shallow-copy x))) @@ -348,9 +348,9 @@ *gc-consitency-check*) (let ((a *x*)) (vector-push (%object-lispval x) a) - (vector-push (memref (object-location x) 0 0 :unsigned-byte32) a) + (vector-push (memref (object-location x) 0 :type :unsigned-byte32) a) (assert (vector-push (%object-lispval forward-x) a)))) - (setf (memref (object-location x) 0 0 :lisp) forward-x) + (setf (memref (object-location x) 0) forward-x) forward-x)))))))) ;; Scavenge roots (dolist (range muerte::%memory-map-roots%) @@ -375,7 +375,7 @@ ((>= i (length a))) (let ((old (%lispval-object (aref a i))) (old-class (aref a (+ i 1)))) - (setf (memref (object-location old) 0 0 :unsigned-byte32) old-class))) + (setf (memref (object-location old) 0 :type :unsigned-byte32) old-class))) ;; Then, check that each migrated object is equalp to its new self. (do ((i 0 (+ i 3))) ((>= i (length a)))

1 0