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

[movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp
by Frode Vatvedt Fjeld 24 Sep '04

24 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv31289 Modified Files: inspect.lisp Log Message: shallow-copy had a bug wrt. vectors, because the elements were copied by considering the original vector as a sequence, and therefore any elements beyond the fill-pointer were not copied. Also, the new copying strategy should be considerably faster. Date: Fri Sep 24 11:33:16 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.41 movitz/losp/muerte/inspect.lisp:1.42 --- movitz/losp/muerte/inspect.lisp:1.41 Thu Sep 23 11:32:15 2004 +++ movitz/losp/muerte/inspect.lisp Fri Sep 24 11:33:16 2004 @@ -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.41 2004/09/23 09:32:15 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.42 2004/09/24 09:33:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -178,12 +178,24 @@ (:cmpl :esi :edx) (:jne 'copy-loop) (:movl (:ebp -4) :esi) -;;; ;; Copy tag from EBX onto EAX -;;; (:movl :ebx :ecx) -;;; (:andl 7 :ecx) -;;; (:andl -8 :eax) -;;; (:orl :ecx :eax) - ;; Load word-count into ECX + (:movl :edx :ecx))) + +(defun %shallow-copy-non-pointer-object (object word-count) + "Copy any object with size word-count." + (check-type word-count (integer 2 *)) + (with-non-pointer-allocation-assembly (word-count + :object-register :eax + :size-register :ecx) + (:load-lexical (:lexical-binding object) :ebx) + (:load-lexical (:lexical-binding word-count) :edx) + (:xorl :esi :esi) ; counter + copy-loop + (:movl (:ebx :esi #.movitz:+other-type-offset+) :ecx) + (:movl :ecx (:eax :esi #.movitz:+other-type-offset+)) + (:addl 4 :esi) + (:cmpl :esi :edx) + (:jne 'copy-loop) + (:movl (:ebp -4) :esi) (:movl :edx :ecx))) (defun shallow-copy (old) @@ -199,12 +211,7 @@ (symbol (copy-symbol old t)) (vector - (let ((new (make-array (array-dimension old 0) - :element-type (array-element-type old) - :initial-contents old))) - (when (array-has-fill-pointer-p old) - (setf (fill-pointer new) (fill-pointer old))) - new)) + (copy-vector old)) (function (copy-funobj old)) (structure-object

1 0

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

24 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv31262 Modified Files: arrays.lisp Log Message: Added function copy-vector. Date: Fri Sep 24 11:31:19 2004 Author: ffjeld Index: movitz/losp/muerte/arrays.lisp diff -u movitz/losp/muerte/arrays.lisp:1.43 movitz/losp/muerte/arrays.lisp:1.44 --- movitz/losp/muerte/arrays.lisp:1.43 Wed Sep 22 16:46:38 2004 +++ movitz/losp/muerte/arrays.lisp Fri Sep 24 11:31:19 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.43 2004/09/22 14:46:38 ffjeld Exp $ +;;;; $Id: arrays.lisp,v 1.44 2004/09/24 09:31:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -153,6 +153,31 @@ "Vector has no fill-pointer.") (%basic-vector-fill-pointer vector)))) +(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)))))) (defun (setf fill-pointer) (new-fill-pointer vector) (etypecase vector

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/textmode.lisp
by Frode Vatvedt Fjeld 23 Sep '04

23 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv11495 Modified Files: textmode.lisp Log Message: *** empty log message *** Date: Thu Sep 23 13:05:51 2004 Author: ffjeld Index: movitz/losp/x86-pc/textmode.lisp diff -u movitz/losp/x86-pc/textmode.lisp:1.11 movitz/losp/x86-pc/textmode.lisp:1.12 --- movitz/losp/x86-pc/textmode.lisp:1.11 Thu Aug 12 18:54:51 2004 +++ movitz/losp/x86-pc/textmode.lisp Thu Sep 23 13:05:51 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 15:38:56 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: textmode.lisp,v 1.11 2004/08/12 16:54:51 ffjeld Exp $ +;;;; $Id: textmode.lisp,v 1.12 2004/09/23 11:05:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -244,6 +244,9 @@ (defun set-textmode (mode-state) + (unless (= #xb8000 (vga-memory-map)) + (break "This is only likely to work on VGA based at #xb8000, yours is at ~S." + (vga-memory-map))) (setf (vga-state) mode-state) (ecase (vga-character-height) (8 (write-font +vga-font-8x8+ 8))

1 0

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

23 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17843 Modified Files: inspect.lisp Log Message: Removed obsoleted operator malloc-pointer-words. Date: Thu Sep 23 11:32:15 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.40 movitz/losp/muerte/inspect.lisp:1.41 --- movitz/losp/muerte/inspect.lisp:1.40 Wed Sep 22 19:39:04 2004 +++ movitz/losp/muerte/inspect.lisp Thu Sep 23 11:32:15 2004 @@ -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.40 2004/09/22 17:39:04 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.41 2004/09/23 09:32:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -159,18 +159,6 @@ (declare (ignore context)) (when (member :catch types) (format t "~&catch: ~Z: ~S" tag tag)))))) - - -(defun malloc-pointer-words (words) - (check-type words (integer 2 *)) - (with-allocation-assembly (words :fixed-size-p t - :object-register :eax - :size-register :ecx) - (:load-lexical (:lexical-binding words) :ecx) -;;; (:leal (:eax :ecx #.movitz:+other-type-offset+) :edx) -;;; (:testb 3 :dl) -;;; (:jnz '(:sub-program () (:int 63))) - (:movl :edi (:eax :ecx #.movitz:+other-type-offset+)))) (defun %shallow-copy-object (object word-count) "Copy any object with size word-count."

1 0

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

23 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17705 Modified Files: defstruct.lisp Log Message: Improved the generation of defstruct constructors. Date: Thu Sep 23 11:31:28 2004 Author: ffjeld Index: movitz/losp/muerte/defstruct.lisp diff -u movitz/losp/muerte/defstruct.lisp:1.13 movitz/losp/muerte/defstruct.lisp:1.14 --- movitz/losp/muerte/defstruct.lisp:1.13 Wed Sep 15 12:22:59 2004 +++ movitz/losp/muerte/defstruct.lisp Thu Sep 23 11:31:28 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.13 2004/09/15 10:22:59 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.14 2004/09/23 09:31:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -229,60 +229,50 @@ . (:translate-when :eval ,slot-names :cl :muerte.cl))) (defclass ,struct-name (,superclass) () (:metaclass structure-class) - (:slots ,(loop for (name) in canonical-slot-descriptions + (:slots ,(loop for (name init-form type read-only init-arg) + in canonical-slot-descriptions as location upfrom 0 collect (movitz-make-instance 'structure-slot-definition :name name + :initarg init-arg + :initform init-form + :type type + :readonly read-only :location location)))) ,@(loop for constructor in (getf options :constructor) if (and constructor (symbolp constructor)) collect - `(defun ,constructor (&key ,@key-lambda) - (let ((s (malloc-pointer-words ,(+ 2 (length slot-names))))) - (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::class) - 0 :lisp) - (compile-time-find-class ,struct-name)) - (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::type) - 0 :unsigned-byte8) - #.(movitz::tag :defstruct)) - (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::length) - 0 :unsigned-byte16) - ,(* movitz:+movitz-fixnum-factor+ (length slot-names))) - ,@(loop for slot-name in slot-names as i upfrom 0 collecting - `(setf (memref s #.(bt:slot-offset 'movitz::movitz-struct - 'movitz::slot0) - ,i :lisp) - ,slot-name)) - s)) + `(defun ,constructor (&rest args) ; &key ,@key-lambda) + (declare (dynamic-extent args)) + (apply 'make-structure ',struct-name args)) else if (and constructor (listp constructor)) collect (let* ((boa-constructor (car constructor)) (boa-lambda-list (cdr constructor)) (boa-variables (movitz::list-normal-lambda-list-variables boa-lambda-list))) `(defun ,boa-constructor ,boa-lambda-list - (let ((s (malloc-pointer-words ,(+ 2 (length slot-names))))) - (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::class) - 0 :lisp) - (compile-time-find-class ,struct-name)) - (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::type) - 0 :unsigned-byte8) - #.(movitz::tag :defstruct)) - (setf (memref s #.(bt:slot-offset 'movitz::movitz-struct 'movitz::length) - 0 :unsigned-byte16) - ,(* movitz:+movitz-fixnum-factor+ (length slot-names))) - ,@(loop for slot-name in slot-names as i upfrom 0 - if (member slot-name boa-variables) - collect - `(setf (memref s #.(bt:slot-offset 'movitz::movitz-struct - 'movitz::slot0) - ,i :lisp) - ,slot-name) - else collect - `(setf (memref s #.(bt:slot-offset 'movitz::movitz-struct - 'movitz::slot0) - ,i :lisp) - nil)) - s))) + (let ((class (compile-time-find-class ,struct-name))) + (with-allocation-assembly (,(+ 2 (length slot-names)) + :fixed-size-p t + :object-register :eax) + (:movl ,(dpb (length slot-names) + (byte 18 14) + (movitz:tag :defstruct)) + (:eax (:offset movitz-struct type))) + (:load-lexical (:lexical-binding class) :ebx) + (:movl :ebx (:eax (:offset movitz-struct class))) + ,@(loop for slot-name in slot-names as i upfrom 0 + if (member slot-name boa-variables) + append + `((:load-lexical (:lexical-binding ,slot-name) :ebx) + (:movl :ebx (:eax (:offset movitz-struct slot0) + ,(* 4 i)))) + else append + `((:movl :edi (:eax (:offset movitz-struct slot0) + ,(* 4 i))))) + ,@(when (oddp (length slot-names)) + `((:movl :edi (:eax (:offset movitz-struct slot0) + ,(* 4 (length slot-names)))))))))) else if constructor do (error "Don't know how to make class-struct constructor: ~S" constructor)) ,(when predicate-name

1 0

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

23 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12314 Modified Files: bignums.lisp Log Message: Removed an ":int 32" that was a leftover debugging statement. Date: Thu Sep 23 11:17:51 2004 Author: ffjeld Index: movitz/losp/muerte/bignums.lisp diff -u movitz/losp/muerte/bignums.lisp:1.10 movitz/losp/muerte/bignums.lisp:1.11 --- movitz/losp/muerte/bignums.lisp:1.10 Wed Sep 22 18:22:45 2004 +++ movitz/losp/muerte/bignums.lisp Thu Sep 23 11:17:51 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.10 2004/09/22 16:22:45 ffjeld Exp $ +;;;; $Id: bignums.lisp,v 1.11 2004/09/23 09:17:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -383,7 +383,6 @@ (:shldl :cl :eax :edx) (jnz 'overflow) shift-short-loop - (:int 32) (:movl (:ebx :esi (:offset movitz-bignum bigit0 -4)) :eax) (:shldl :cl :eax (:ebx :esi (:offset movitz-bignum bigit0)))

1 0

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

23 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11359 Modified Files: los-closette.lisp Log Message: Improved make-structure to observe initargs and initforms properly. Date: Thu Sep 23 11:11:26 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.19 movitz/losp/muerte/los-closette.lisp:1.20 --- movitz/losp/muerte/los-closette.lisp:1.19 Thu Sep 23 09:21:38 2004 +++ movitz/losp/muerte/los-closette.lisp Thu Sep 23 11:11:26 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.19 2004/09/23 07:21:38 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.20 2004/09/23 09:11:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1101,10 +1101,21 @@ (defclass structure-slot-definition (slot-definition) ((name - :initarg :name) + :initarg :name + :reader structure-slot-name) (location :initarg :location - :reader structure-slot-location))) + :reader structure-slot-location) + (initarg + :initarg :initarg + :reader structure-slot-initarg) + (initform + :initarg :initform + :reader structure-slot-initform) + (type + :initarg type) + (readonly + :initarg :readonly))) (defclass structure-object (t) () (:metaclass structure-class)) @@ -1137,14 +1148,15 @@ (:jmp 'init-loop) init-done))) (do-it)))) - (do ((p init-args (cddr p))) - ((endp p)) - (let ((slot-position (position (car p) slots :key #'fifth))) - (assert slot-position () - "Illegal init-arg ~S for ~S." (car p) class) - (setf (structure-ref struct slot-position) (cadr p)))) + (dolist (slot slots) + (let ((init-value (getf init-args (structure-slot-initarg slot) 'no-initarg))) + (if (not (eq init-value 'no-initarg)) + (setf (structure-ref struct (structure-slot-location slot)) init-value) + (let ((initform (structure-slot-initform slot))) + (when initform + (setf (structure-ref struct (structure-slot-location slot)) + (eval initform))))))) struct))) - ;;;;

1 0

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

23 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9890 Modified Files: los-closette.lisp Log Message: Removed more instances of malloc-pointer-words usage. Date: Thu Sep 23 09:21:38 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.18 movitz/losp/muerte/los-closette.lisp:1.19 --- movitz/losp/muerte/los-closette.lisp:1.18 Wed Jul 28 12:01:11 2004 +++ movitz/losp/muerte/los-closette.lisp Thu Sep 23 09:21:38 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.18 2004/07/28 10:01:11 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.19 2004/09/23 07:21:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -119,14 +119,17 @@ (defun allocate-std-instance (class slots) - (let ((instance (malloc-pointer-words 4))) - (setf (memref instance #.(bt:slot-offset 'movitz:movitz-struct 'movitz:type) - 0 :unsigned-byte8) - #.(movitz:tag :std-instance)) - (setf-movitz-accessor (instance movitz-std-instance dummy) nil) - (setf (std-instance-class instance) class - (std-instance-slots instance) slots) - instance)) + (macrolet + ((do-it () + `(with-allocation-assembly (4 :fixed-size-p t + :object-register :eax) + (:load-lexical (:lexical-binding class) :ebx) + (:load-lexical (:lexical-binding slots) :edx) + (:movl ,(movitz:tag :std-instance) (:eax (:offset movitz-std-instance type))) + (:movl :edi (:eax (:offset movitz-std-instance dummy))) + (:movl :ebx (:eax (:offset movitz-std-instance class))) + (:movl :edx (:eax (:offset movitz-std-instance slots)))))) + (do-it))) (defun std-allocate-instance (class) (allocate-std-instance class @@ -1111,18 +1114,29 @@ (check-type class structure-class) (let* ((slots (class-slots class)) (num-slots (length slots)) - (struct (malloc-pointer-words (+ 2 num-slots)))) - (setf (memref struct #.(bt:slot-offset 'movitz::movitz-struct 'movitz::class) - 0 :lisp) - class) - (setf (memref struct #.(bt:slot-offset 'movitz::movitz-struct 'movitz::type) - 0 :unsigned-byte8) - #.(movitz::tag :defstruct)) - (setf (memref struct #.(bt:slot-offset 'movitz::movitz-struct 'movitz::length) - 0 :unsigned-byte16) - num-slots) - (dotimes (i num-slots) - (setf (structure-ref struct i) nil)) + (words (+ 2 num-slots)) + (struct (macrolet + ((do-it () + `(with-allocation-assembly (words :fixed-size-p t + :object-register :eax) + (:load-lexical (:lexical-binding num-slots) :ecx) + (:movl :ecx :edx) + (:shll 16 :ecx) + (:orl ,(movitz:tag :defstruct 0) :ecx) + (:movl :ecx (:eax (:offset movitz-struct type))) + (:load-lexical (:lexical-binding class) :ebx) + (:movl :ebx (:eax (:offset movitz-struct class))) + (:addl 4 :edx) + (:andl -8 :edx) + (:xorl :ecx :ecx) + init-loop + (:cmpl :ecx :edx) + (:jbe 'init-done) + (:movl :edi (:eax (:offset movitz-struct slot0) :ecx)) + (:addl 4 :ecx) + (:jmp 'init-loop) + init-done))) + (do-it)))) (do ((p init-args (cddr p))) ((endp p)) (let ((slot-position (position (car p) slots :key #'fifth)))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/symbols.lisp
by Frode Vatvedt Fjeld 22 Sep '04

22 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18461 Modified Files: symbols.lisp Log Message: Fixed creation and copying of symbols not to use malloc-pointer-words. Date: Wed Sep 22 20:49:24 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.18 movitz/losp/muerte/symbols.lisp:1.19 --- movitz/losp/muerte/symbols.lisp:1.18 Thu Jul 29 02:13:22 2004 +++ movitz/losp/muerte/symbols.lisp Wed Sep 22 20:49:24 2004 @@ -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.18 2004/07/29 00:13:22 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.19 2004/09/22 18:49:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -143,17 +143,31 @@ (flags 0)) (eval-when (:compile-toplevel) (assert (= 1 (- (movitz:tag :symbol) (movitz:tag :other))))) - (let ((symbol (%word-offset (malloc-pointer-words 6) 1))) - (setf-movitz-accessor (symbol movitz-symbol package) package) - (setf-movitz-accessor (symbol movitz-symbol name) name) - (setf (memref symbol #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::hash-key) - 0 :unsigned-byte16) - (sxhash name)) - (setf (symbol-flags symbol) flags - (symbol-plist symbol) plist - (symbol-function symbol) function - (symbol-value symbol) value) - symbol)) + (let ((sxhash (sxhash name))) + (macrolet + ((do-it () + `(with-non-pointer-allocation-assembly (6 :fixed-size-p t + :object-register :eax) + (:addl ,(- (movitz:tag :symbol) (movitz:tag :other)) :eax) + (:load-lexical (:lexical-binding package) :ebx) + (:movl :ebx (:eax (:offset movitz-symbol package))) + (:load-lexical (:lexical-binding name) :ebx) + (:movl :ebx (:eax (:offset movitz-symbol name))) + (:load-lexical (:lexical-binding function) :ebx) + (:movl :ebx (:eax (:offset movitz-symbol function-value))) + (:load-lexical (:lexical-binding plist) :ebx) + (:movl :ebx (:eax (:offset movitz-symbol plist))) + (:load-lexical (:lexical-binding value) :ebx) + (:movl :ebx (:eax (:offset movitz-symbol value))) + + (:load-lexical (:lexical-binding flags) :ecx) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) + (:load-lexical (:lexical-binding sxhash) :ebx) + (:shll ,(- 16 movitz:+movitz-fixnum-shift+) :ebx) + (:orl :ebx :ecx) + (:movl :ecx (:eax (:offset movitz-symbol flags))) + ))) + (do-it)))) (defun make-symbol (name) (check-type name string "a symbol name") @@ -166,11 +180,29 @@ (if (or (eq nil symbol) (not copy-properties)) (%create-symbol (symbol-name symbol)) - (let ((x (%word-offset (malloc-pointer-words 6) 1))) - (dotimes (i 6) - (setf (memref x #.(cl:- (movitz:tag :symbol)) i :lisp) - (memref symbol #.(cl:- (movitz:tag :symbol)) i :lisp))) - x))) + (with-allocation-assembly (6 :object-register :eax + :fixed-size-p t) + (:addl 1 :eax) + (:load-lexical (:lexical-binding symbol) :ebx) + ;; 0 + (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 0) :ecx) + (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 0)) + ;; 1 + (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 4) :ecx) + (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 4)) + ;; 2 + (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 8) :ecx) + (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 8)) + ;; 3 + (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 12) :ecx) + (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 12)) + ;; 4 + (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 16) :ecx) + (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 16)) + ;; 5 + (:movl (:ebx #.(cl:- (movitz:tag :symbol)) 20) :ecx) + (:movl :ecx (:eax #.(cl:- (movitz:tag :symbol)) 20))))) + (defun symbol-flags (symbol) (etypecase symbol

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp
by Frode Vatvedt Fjeld 22 Sep '04

22 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv6294 Modified Files: debugger.lisp Log Message: Improved backtrace's ability to figure out what is the frame's function-name etc, even for primitive-functions. Date: Wed Sep 22 20:00:56 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.24 movitz/losp/x86-pc/debugger.lisp:1.25 --- movitz/losp/x86-pc/debugger.lisp:1.24 Wed Sep 15 12:23:09 2004 +++ movitz/losp/x86-pc/debugger.lisp Wed Sep 22 20:00:55 2004 @@ -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.24 2004/09/15 10:23:09 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.25 2004/09/22 18:00:55 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -441,6 +441,14 @@ (assert (location-in-object-p vector location)) (- location (object-location vector) 2)) +(defun find-primitive-code-vector-by-eip (eip &optional (context (current-run-time-context))) + (loop with location = (truncate eip 4) + for (slot-name type) in (slot-value (class-of context) 'slot-map) + do (when (eq type 'code-vector-word) + (let ((code-vector (%run-time-context-slot slot-name))) + (when (location-in-object-p code-vector location) + (return (values slot-name (code-vector-offset code-vector eip)))))))) + (defun backtrace (&key (stack nil) ((:frame initial-stack-frame-index) (if stack @@ -485,30 +493,68 @@ (format t "#x~X " frame)))) (typecase funobj ((eql 0) - (let* (#+ignore (dit-frame (if (null stack) frame (+ frame 2 (object-location stack)))) - (funobj (dit-frame-ref stack frame :esi))) - (setf next-frame (dit-frame-casf stack frame)) - (if (and conflate-interrupts conflate - ;; When the interrupted function has a stack-frame, conflate it. - (typep funobj 'function) - (= 1 (ldb (byte 1 5) (funobj-debug-info funobj)))) - (incf conflate-count) - (progn - (incf count) - (print-leadin stack frame count conflate-count) - (setf conflate-count 0) - (let ((exception (dit-frame-ref stack frame :exception-vector :unsigned-byte32)) - (eip (dit-frame-ref stack frame :eip :unsigned-byte32))) - (typecase funobj - (function - (let ((delta (code-vector-offset (funobj-code-vector funobj) eip))) - (if delta - (format t "{Exception ~D in ~W at PC offset ~D.}" - exception (funobj-name funobj) delta) - (format t "{Exception ~D in ~W at EIP=#x~X.}" - exception (funobj-name funobj) eip)))) - (t (format t "{Exception ~D with ESI=~Z and EIP=#x~X.}" - exception funobj eip)))))))) + (let ((eip (dit-frame-ref stack frame :eip :unsigned-byte32)) + (casf (dit-frame-casf stack frame))) + (multiple-value-bind (function-name code-vector-offset) + (let ((casf-funobj (stack-frame-funobj stack casf))) + (cond + ((eq 0 casf-funobj) + (values 'default-interrupt-trampoline + (code-vector-offset (slot-value 'default-interrupt-trampoline) + eip))) + ((not (typep casf-funobj 'function)) + ;; Hm.. very suspicius + (warn "Weird frame ~S" frame) + (values nil)) + (t (let ((x (code-vector-offset (funobj-code-vector casf-funobj) eip))) + (cond + ((not (eq nil x)) + (values (funobj-name casf-funobj) x)) + ((not (logbitp 10 (dit-frame-ref stack frame :eflags :unsigned-byte16))) + (let ((funobj2 (dit-frame-ref stack frame :esi :lisp))) + (or (when (typep funobj2 'function) + (let ((x (code-vector-offset (funobj-code-vector funobj2) eip))) + (when x + (values (funobj-name funobj2) x)))) + (find-primitive-code-vector-by-eip eip))))))))) + (setf next-frame (dit-frame-casf stack frame)) + (if (and conflate-interrupts conflate + ;; When the interrupted function has a stack-frame, conflate it. + (typep funobj 'function) + (= 1 (ldb (byte 1 5) (funobj-debug-info funobj)))) + (incf conflate-count) + (progn + (incf count) + (print-leadin stack frame count conflate-count) + (setf conflate-count 0) + (let ((exception (dit-frame-ref stack frame :exception-vector :unsigned-byte32))) + (if function-name + (format t "DIT exception ~D in ~W at PC offset ~D." + exception + function-name + code-vector-offset) + (format t "DIT exception ~D at EIP=~S with ESI=~S." + exception + eip + (dit-frame-ref stack frame :esi :unsigned-byte32))) + #+ignore + (typecase funobj + (function + (let ((delta (code-vector-offset (funobj-code-vector funobj) eip))) + (if delta + (format t "DIT Exception ~D in ~W at PC offset ~D." + exception (funobj-name funobj) delta) + (multiple-value-bind (primitive-name primitive-vector) + (find-primitive-code-vector-by-location (truncate eip 4)) + (if (not primitive-name) + (format t "DIT Exception ~D in ~W at EIP=#x~X." + exception (funobj-name funobj) eip) + (format t "DIT Exception ~D in primitive-function ~A at PC offset ~D." + exception + primitive-name + (code-vector-offset primitive-vector eip))))))) + (t (format t "DIT Exception ~D with ESI=~Z and EIP=#x~X." + exception funobj eip))))))))) (function (let ((name (funobj-name funobj))) (cond

1 0