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

[movitz-cvs] CVS update: movitz/storage-types.lisp
by Frode Vatvedt Fjeld 17 Sep '04

17 Sep '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5929 Modified Files: storage-types.lisp Log Message: Fixed tag-name to do the right thing. Date: Fri Sep 17 13:06:05 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.40 movitz/storage-types.lisp:1.41 --- movitz/storage-types.lisp:1.40 Wed Sep 15 12:22:52 2004 +++ movitz/storage-types.lisp Fri Sep 17 13:06:05 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.40 2004/09/15 10:22:52 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.41 2004/09/17 11:06:05 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -94,7 +94,8 @@ (ash wide-tag 8))) (defun tag-name (number) - (bt:enum-symbolic-value 'other-type-byte number)) + (find number '(:even-fixnum :odd-fixnum :cons :character :null :other :symbol) + :key 'tag)) (defun extract-tag (word) (tag-name (ldb (byte 3 0) word)))

1 0

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

16 Sep '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv8512 Modified Files: los0-gc.lisp Log Message: *** empty log message *** Date: Thu Sep 16 10:55:00 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.36 movitz/losp/los0-gc.lisp:1.37 --- movitz/losp/los0-gc.lisp:1.36 Wed Sep 15 12:22:57 2004 +++ movitz/losp/los0-gc.lisp Thu Sep 16 10:55:00 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.36 2004/09/15 10:22:57 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.37 2004/09/16 08:55:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -205,8 +205,6 @@ (:jae '(:sub-program () (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) (:edi (:edi-offset atomically-status)))) - (:movl :edx (#x1000000)) - (:addl :eax (#x1000000)) (:int 113) ; This interrupt can be retried. (:jmp 'retry-cons))) (:movl ,(dpb movitz:+movitz-fixnum-factor+ @@ -320,9 +318,7 @@ (install-primitive los0-fast-cons muerte::fast-cons) (install-primitive los0-box-u32-ecx muerte::box-u32-ecx) (install-primitive los0-get-cons-pointer muerte::get-cons-pointer) - (install-primitive los0-cons-commit muerte::cons-commit) - #+ignore (install-primitive los0-malloc-pointer-words muerte::malloc-pointer-words) - #+ignore (install-primitive los0-malloc-non-pointer-words muerte::malloc-non-pointer-words)) + (install-primitive los0-cons-commit muerte::cons-commit)) (if (eq context (current-run-time-context)) (setf (%run-time-context-slot 'muerte::nursery-space) actual-duo-space) @@ -380,6 +376,8 @@ (defparameter *x* #4000()) ; Have this in static space. +(defparameter *xx* #4000()) ; Have this in static space. + (defun stop-and-copy (&optional evacuator) (setf (fill-pointer *x*) 0) @@ -428,7 +426,6 @@ (assert (vector-push (%object-lispval forward-x) a)))) (setf (memref (object-location x) 0 0 :lisp) forward-x) forward-x)))))))) - (setf *gc-stack* (muerte::copy-current-control-stack)) ;; Scavenge roots (dolist (range muerte::%memory-map-roots%) (map-heap-words evacuator (car range) (cdr range))) @@ -479,7 +476,10 @@ ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%" old-size new-size (- old-size new-size)))) (initialize-space oldspace) - (fill oldspace #x13 :start 2))) + (fill oldspace #x13 :start 2) + (setf *gc-stack* (muerte::copy-current-control-stack)) + (setf (fill-pointer *xx*) (fill-pointer *x*)) + (replace *xx* *x*))) (values))

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 16 Sep '04

16 Sep '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv6403 Modified Files: image.lisp Log Message: The non-pointers part of the run-time-context wasn't quite correct. Date: Thu Sep 16 10:50:56 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.67 movitz/image.lisp:1.68 --- movitz/image.lisp:1.67 Wed Sep 15 12:22:52 2004 +++ movitz/image.lisp Thu Sep 16 10:50:54 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.67 2004/09/15 10:22:52 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.68 2004/09/16 08:50:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -409,10 +409,10 @@ (declare (ignore x type)) (- (bt:slot-offset 'movitz-run-time-context 'non-pointers-end) (bt:slot-offset 'movitz-run-time-context 'non-pointers-start)))) + (non-pointers-start :binary-type :label) ; ========= NON-POINTER-START ======= (bochs-flags :binary-type lu32 :initform 0) - (non-pointers-start :binary-type :label) ; ========= NON-POINTER-START ======= ;; (align-segment-descriptors :binary-type 4) (segment-descriptor-table :binary-type :label) (segment-descriptor-0

1 0

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

15 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9927 Modified Files: inspect.lisp Log Message: Removed dead code. Date: Wed Sep 15 12:25:47 2004 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.37 movitz/losp/muerte/inspect.lisp:1.38 --- movitz/losp/muerte/inspect.lisp:1.37 Wed Sep 15 12:22:59 2004 +++ movitz/losp/muerte/inspect.lisp Wed Sep 15 12:25:47 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.37 2004/09/15 10:22:59 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.38 2004/09/15 10:25:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -393,36 +393,3 @@ (- uplink start-frame))) (setf frame uplink))) copy)) - -;;; (let* ((stack-start-location (+ 2 (object-location stack))) -;;; (start-frame-index (- start-frame stack-start-location)) -;;; (copy (subseq stack start-frame-index)) -;;; (copy-start-location (+ 2 (object-location copy)))) -;;; (do ((frame start-frame-index) -;;; (index 0)) -;;; (nil) -;;; (let ((uplink-frame (stack-frame-uplink stack frame))) -;;; (cond -;;; ((= 0 uplink-frame) -;;; (setf (svref%unsafe copy index) 0) -;;; (return copy)) -;;; (t (let* ((uplink-frame (- uplink-frame stack-start-location)) -;;; (uplink-index (- uplink-frame start-frame-index))) -;;; (warn "~S uf ~S [~S]" -;;; (+ frame stack-start-location) -;;; (+ uplink-frame stack-start-location) -;;; frame) -;;; (assert (< -1 uplink-index (length copy)) () -;;; "Uplink-index outside copy: ~S, uplink-frame: ~S frame: ~S, index: ~S" -;;; uplink-index uplink-frame (+ frame stack-start-location) index) -;;; (setf (svref%unsafe copy index) -;;; (if relative-uplinks -;;; uplink-index -;;; (let ((x (+ uplink-index copy-start-location))) -;;; (assert (= copy-start-location (+ 2 (object-location copy))) () -;;; "Destination stack re-located!") -;;; (assert (location-in-object-p copy x) () -;;; "Bad uplink ~S computed from index ~S and copy ~Z, csl: ~S" -;;; x uplink-index copy copy-start-location) -;;; x))) -;;; (setf frame uplink-frame index uplink-index))))))))

1 0

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

15 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv7579/losp/x86-pc Modified Files: debugger.lisp Log Message: many cleanup regarding stack and register discipline. Date: Wed Sep 15 12:23:12 2004 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.23 movitz/losp/x86-pc/debugger.lisp:1.24 --- movitz/losp/x86-pc/debugger.lisp:1.23 Thu Sep 2 11:41:18 2004 +++ movitz/losp/x86-pc/debugger.lisp Wed Sep 15 12:23:09 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.23 2004/09/02 09:41:18 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.24 2004/09/15 10:23:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -118,6 +118,8 @@ (0 . (#xb1 #x00 #xff #x56 ; movb 0 :cl #.(cl:ldb (cl:byte 8 0) (bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector)))) + (2 . (#xff #x57 + #.(movitz:global-constant-offset 'fast-compare-two-reals))) (:ecx . (#xff #x56 #.(cl:ldb (cl:byte 8 0) (bt:slot-offset 'movitz::movitz-funobj 'movitz::code-vector)))))) @@ -227,6 +229,7 @@ (:* 1 ((:or (#xb1 (:cl-numargs))))) ; (:movb x :cl) (:* 1 ((:or (#x8b #x55 (:edx :ebp)) (#x8b #x56 (:edx :esi))))) + (:* 4 (#x90)) ; (:nop) #xff #x56 (:code-vector)))) ; (:call (:esi x)) ;; APPLY 3 args ((20 20 . (#x8b #x5d (:ebx :ebp) ; #<asm MOVL [#x-c+%EBP] => %EBX> @@ -455,15 +458,17 @@ (*standard-output* *debug-io*) (*print-length* *backtrace-print-length*) (*print-level* *backtrace-print-level*)) - (loop with conflate-count = 0 with count = 0 + (loop with conflate-count = 0 with count = 0 with next-frame = nil for frame = initial-stack-frame-index - then (let ((uplink (stack-frame-uplink stack frame))) - (assert (> uplink frame) () - "Backtracing uplink ~S from frame index ~S." uplink frame) - uplink) + then (or next-frame + (let ((uplink (stack-frame-uplink stack frame))) + (assert (> uplink frame) () + "Backtracing uplink ~S from frame index ~S." uplink frame) + uplink)) ;; as xxx = (warn "frame: ~S" frame) as funobj = (stack-frame-funobj stack frame) - do (flet ((print-leadin (stack frame count conflate-count) + do (setf next-frame nil) + (flet ((print-leadin (stack frame count conflate-count) (when *backtrace-do-fresh-lines* (fresh-line)) (cond @@ -480,8 +485,9 @@ (format t "#x~X " frame)))) (typecase funobj ((eql 0) - (let* ((dit-frame (if (null stack) frame (+ frame 2 (object-location stack)))) - (funobj (dit-frame-ref :esi :lisp 0 dit-frame))) + (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) @@ -491,10 +497,8 @@ (incf count) (print-leadin stack frame count conflate-count) (setf conflate-count 0) - (let ((exception (dit-frame-ref :exception-vector :unsigned-byte32 - 0 dit-frame)) - (eip (dit-frame-ref :eip :unsigned-byte32 - 0 dit-frame))) + (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))) @@ -546,6 +550,7 @@ (string= name 'toplevel-function)) (write-char #\.) (return)))))) - (t (format t "~&?: ~Z" funobj)))))) + (t (print-leadin stack frame count conflate-count) + (format t "?: ~Z" funobj)))))) (values))

1 0

15 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7579/losp/muerte Modified Files: basic-macros.lisp bignums.lisp defstruct.lisp functions.lisp inspect.lisp integers.lisp interrupt.lisp memref.lisp more-macros.lisp primitive-functions.lisp scavenge.lisp typep.lisp variables.lisp Log Message: many cleanup regarding stack and register discipline. Date: Wed Sep 15 12:22:59 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.38 movitz/losp/muerte/basic-macros.lisp:1.39 --- movitz/losp/muerte/basic-macros.lisp:1.38 Thu Aug 19 00:35:45 2004 +++ movitz/losp/muerte/basic-macros.lisp Wed Sep 15 12:22:59 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.38 2004/08/18 22:35:45 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.39 2004/09/15 10:22:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1066,7 +1066,52 @@ (define-symbol-macro ,name (%symbol-global-value ',name)))) (define-compiler-macro assembly-register (register) - `(with-inline-assembly (:returns ,register))) + `(with-inline-assembly (:returns :eax) + (:movl ,register :eax))) + +(defmacro with-allocation-assembly + ((size-form &key object-register size-register fixed-size-p labels) &body code) + (assert (eq object-register :eax)) + (assert (or fixed-size-p (eq size-register :ecx))) + (let ((size-var (gensym "malloc-size-"))) + `(let ((,size-var ,size-form)) + (with-inline-assembly (:returns :eax :labels (retry-alloc retry-jumper ,@labels)) + (:declare-label-set retry-jumper (retry-alloc)) + retry-alloc + (:locally (:movl :esp (:edi (:edi-offset atomically-esp)))) + (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) + 'retry-jumper) + (:edi (:edi-offset atomically-status)))) + (:load-lexical (:lexical-binding ,size-var) :eax) + (:call-local-pf get-cons-pointer) + ,@code + ,@(when fixed-size-p + `((:load-lexical (:lexical-binding ,size-var) :ecx))) + (:call-local-pf cons-commit) + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))))))) + +(defmacro with-non-pointer-allocation-assembly + ((size-form &key object-register size-register fixed-size-p labels) &body code) + (assert (eq object-register :eax)) + (assert (or fixed-size-p (eq size-register :ecx))) + (let ((size-var (gensym "malloc-size-"))) + `(let ((,size-var ,size-form)) + (with-inline-assembly (:returns :eax :labels (retry-alloc retry-jumper ,@labels)) + (:declare-label-set retry-jumper (retry-alloc)) + retry-alloc + (:locally (:movl :esp (:edi (:edi-offset atomically-esp)))) + (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) + 'retry-jumper) + (:edi (:edi-offset atomically-status)))) + (:load-lexical (:lexical-binding ,size-var) :eax) + (:call-local-pf get-cons-pointer-non-pointer) + ,@code + ,@(when fixed-size-p + `((:load-lexical (:lexical-binding ,size-var) :ecx))) + (:call-local-pf cons-commit-non-pointer) + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status)))))))) (require :muerte/setf) Index: movitz/losp/muerte/bignums.lisp diff -u movitz/losp/muerte/bignums.lisp:1.6 movitz/losp/muerte/bignums.lisp:1.7 --- movitz/losp/muerte/bignums.lisp:1.6 Thu Aug 19 00:36:37 2004 +++ movitz/losp/muerte/bignums.lisp Wed Sep 15 12:22:59 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.6 2004/08/18 22:36:37 ffjeld Exp $ +;;;; $Id: bignums.lisp,v 1.7 2004/09/15 10:22:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -64,6 +64,8 @@ (defun copy-bignum (old) (check-type old bignum) + (%shallow-copy-object old (1+ (%bignum-bigits old))) + #+ignore (let* ((length (%bignum-bigits old)) (new (malloc-non-pointer-words (1+ length)))) (with-inline-assembly (:returns :eax) @@ -412,15 +414,16 @@ (:load-lexical (:lexical-binding bignum) :ebx) ; bignum (:compile-form (:result-mode :ecx) factor) (:sarl ,movitz:+movitz-fixnum-shift+ :ecx) - (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) + (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) (:xorl :esi :esi) ; Counter (by 4) (:xorl :edx :edx) ; Initial carry (:std) ; Make EAX, EDX non-GC-roots. multiply-loop + (:movl :esi (#x1000000)) (:movl (:ebx :esi (:offset movitz-bignum bigit0)) :eax) (:movl :edx :ecx) ; Save carry in ECX - (:locally (:mull (:edi (:edi-offset scratch0)) :eax :edx)) ; EDX:EAX = scratch0*EAX + (:locally (:mull (:edi (:edi-offset raw-scratch0)) :eax :edx)) ; EDX:EAX = scratch0*EAX (:addl :ecx :eax) ; Add carry (:adcl 0 :edx) ; Compute next carry (:jc '(:sub-program (should-not-happen) (:int 63))) @@ -428,11 +431,11 @@ (:addl 4 :esi) (:cmpw :si (:ebx (:offset movitz-bignum length))) (:ja 'multiply-loop) - (:movl (:ebp -4) :esi) (:movl :edx :ecx) ; Carry into ECX (:movl :edi :eax) (:movl :edi :edx) (:cld) + (:movl (:ebp -4) :esi) (:testl :ecx :ecx) ; Carry overflow? (:jnz '(:sub-program (overflow) (:int 4))) ))) Index: movitz/losp/muerte/defstruct.lisp diff -u movitz/losp/muerte/defstruct.lisp:1.12 movitz/losp/muerte/defstruct.lisp:1.13 --- movitz/losp/muerte/defstruct.lisp:1.12 Tue Jul 27 11:19:09 2004 +++ movitz/losp/muerte/defstruct.lisp Wed Sep 15 12:22:59 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.12 2004/07/27 09:19:09 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.13 2004/09/15 10:22:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -27,17 +27,7 @@ (memref x -6 1 :lisp)) (defun copy-structure (object) - ;; (check-type object structure-object) - (let* ((length (structure-object-length object)) - (copy (malloc-pointer-words (+ 2 length)))) - (setf (memref copy -6 0 :lisp) - (memref object -6 0 :lisp)) - (setf (memref copy -6 1 :unsigned-byte32) - (memref object -6 1 :unsigned-byte32)) - (dotimes (i length) - (setf (structure-ref copy i) - (structure-ref object i))) - copy)) + (%shallow-copy-object object (+ 2 (structure-object-length object)))) (defun struct-predicate-prototype (obj) "Prototype function for predicates of user-defined struct. Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.18 movitz/losp/muerte/functions.lisp:1.19 --- movitz/losp/muerte/functions.lisp:1.18 Mon Aug 16 17:28:07 2004 +++ movitz/losp/muerte/functions.lisp Wed Sep 15 12:22:59 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.18 2004/08/16 15:28:07 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.19 2004/09/15 10:22:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -359,7 +359,6 @@ (defun make-funobj (&key (name :unnamed) (code-vector (funobj-code-vector #'constantly-prototype)) (constants nil) - ;; (num-constants (length constants)) lambda-list) (setf code-vector (etypecase code-vector @@ -372,18 +371,67 @@ (make-array (length code-vector) :element-type 'code :initial-contents code-vector)))) - (let ((funobj (malloc-pointer-words (+ #.(cl:truncate (bt:sizeof 'movitz:movitz-funobj) 4) - (length constants))))) - (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16) - #.(movitz:tag :funobj)) + (let* ((num-constants (length constants)) + (funobj (macrolet + ((do-it () + `(with-allocation-assembly ((+ num-constants + ,(movitz::movitz-type-word-size 'movitz-funobj)) + :object-register :eax + :size-register :ecx) + (:movl ,(movitz:tag :funobj) (:eax ,movitz:+other-type-offset+)) + (:load-lexical (:lexical-binding num-constants) :edx) + (:movl :edx :ecx) + (:shll ,(- 16 movitz:+movitz-fixnum-shift+) :ecx) + (:movl :ecx (:eax (:offset movitz-funobj num-jumpers))) + (:xorl :ecx :ecx) + (:xorl :ebx :ebx) + (:testl :edx :edx) + (:jmp 'init-done) + init-loop + (:movl :ecx (:eax :ebx ,movitz:+other-type-offset+)) + (:addl 4 :ebx) + (:cmpl :ebx :edx) + (:ja 'init-loop) + init-done + (:leal (:edx ,(bt:sizeof 'movitz:movitz-funobj)) :ecx)) + #+ignore + `(with-inline-assembly (:returns :eax :labels (retry-alloc retry-jumper)) + (:declare-label-set retry-jumper (retry-alloc)) + retry-alloc + (:locally (:movl '(:funcall ,(movitz::atomically-status-jumper-fn t :esp) + 'retry-jumper) + (:edi (:edi-offset atomically-status)))) + (:compile-form (:result-mode :eax) + (+ num-constants + #.(cl:truncate (bt:sizeof 'movitz:movitz-funobj) 4))) + (:call-local-pf get-cons-pointer) + (:movl #.(movitz:tag :funobj) (:eax #.movitz:+other-type-offset+)) + (:load-lexical (:lexical-binding num-constants) :edx) + (:movl :edx :ecx) + (:shll #.(cl:- 16 movitz:+movitz-fixnum-shift+) :ecx) + (:movl :ecx (:eax (:offset movitz-funobj num-jumpers))) + (:xorl :ecx :ecx) + (:xorl :ebx :ebx) + (:testl :edx :edx) + (:jmp 'init-done) + init-loop + (:movl :ecx (:eax :ebx #.movitz:+other-type-offset+)) + (:addl 4 :ebx) + (:cmpl :ebx :edx) + (:ja 'init-loop) + init-done + (:leal (:edx #.(bt:sizeof 'movitz:movitz-funobj)) :ecx) + (:call-local-pf cons-commit) + (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) + (:edi (:edi-offset atomically-status))))))) + (do-it)))) (setf (funobj-name funobj) name (funobj-code-vector funobj) code-vector ;; revert to default trampolines for now.. - (funobj-code-vector%1op funobj) (get-global-property :trampoline-funcall%1op) - (funobj-code-vector%2op funobj) (get-global-property :trampoline-funcall%2op) - (funobj-code-vector%3op funobj) (get-global-property :trampoline-funcall%3op) - (funobj-lambda-list funobj) lambda-list - (funobj-num-constants funobj) (length constants)) + (funobj-code-vector%1op funobj) (symbol-value 'trampoline-funcall%1op) + (funobj-code-vector%2op funobj) (symbol-value 'trampoline-funcall%2op) + (funobj-code-vector%3op funobj) (symbol-value 'trampoline-funcall%3op) + (funobj-lambda-list funobj) lambda-list) (do* ((i 0 (1+ i)) (p constants (cdr p)) (x (car p))) @@ -414,14 +462,11 @@ (funobj-constant-ref src i))) dst) -(defun copy-funobj (old-funobj &optional (name (funobj-name old-funobj))) - (let* ((num-constants (funobj-num-constants old-funobj)) - (funobj (malloc-pointer-words (+ #.(movitz::movitz-type-word-size 'movitz-funobj) - num-constants)))) - (setf (memref funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16) - (memref old-funobj #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:type) 0 :unsigned-byte16)) - (setf (funobj-num-constants funobj) num-constants) - (replace-funobj funobj old-funobj name))) +(defun copy-funobj (old-funobj) + (check-type old-funobj function) + (%shallow-copy-object old-funobj + (+ (funobj-num-constants old-funobj) + #.(movitz::movitz-type-word-size 'movitz-funobj)))) (defun install-funobj-name (name funobj) (setf (funobj-name funobj) name) Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.36 movitz/losp/muerte/inspect.lisp:1.37 --- movitz/losp/muerte/inspect.lisp:1.36 Mon Aug 30 17:16:59 2004 +++ movitz/losp/muerte/inspect.lisp Wed Sep 15 12:22:59 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.36 2004/08/30 15:16:59 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.37 2004/09/15 10:22:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -38,8 +38,13 @@ (declare (without-check-stack-limit)) ; we do it explicitly.. (check-stack-limit)) +(defun stack-frame-funobj (stack frame) + (stack-frame-ref stack frame -1)) + (defun stack-frame-uplink (stack frame) - (stack-frame-ref stack frame 0)) + (if (eq 0 (stack-frame-funobj stack frame)) + (dit-frame-casf stack frame) + (stack-frame-ref stack frame 0))) (define-compiler-macro current-stack-frame () `(with-inline-assembly (:returns :eax) @@ -49,15 +54,6 @@ (defun current-stack-frame () (stack-frame-uplink nil (current-stack-frame))) -(defun stack-frame-funobj (stack frame) - (stack-frame-ref stack frame -1) - #+ignore - (when stack-frame - (let ((x (stack-frame-ref stack-frame -1 stack))) - (and (or accept-non-funobjs - (typep x 'function)) - x)))) - (defun stack-frame-call-site (stack frame) "Return the code-vector and offset into this vector that is immediately after the point that called this stack-frame." @@ -83,6 +79,16 @@ (memref stack 2 pos type))) (t (memref frame 0 index type)))) +(defun (setf stack-frame-ref) (value stack frame index &optional (type ':lisp)) + (cond + ((not (eq nil stack)) + (check-type stack (simple-array (unsigned-byte 32) 1)) + (let ((pos (+ frame index))) + (assert (< -1 pos (length stack)) + () "Index ~S, pos ~S, len ~S" index pos (length stack)) + (setf (memref stack 2 pos type) value))) + (t (setf (memref frame 0 index type) value)))) + (defun current-dynamic-context () (with-inline-assembly (:returns :eax) (:locally (:movl (:edi (:edi-offset dynamic-env)) :eax)))) @@ -154,6 +160,57 @@ (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 malloc-non-pointer-words (words) + (check-type words (integer 2 *)) + (with-non-pointer-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." + (check-type word-count (integer 2 *)) + (with-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 + (:addl 4 :edx) + (:andl -8 :edx) + 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) +;;; ;; 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 (old) "Allocate a new object that is similar to the old one." (etypecase old @@ -181,52 +238,55 @@ (defun objects-equalp (x y) "Basically, this verifies whether x is a shallow-copy of y, or vice versa." (or (eql x y) - (if (not (and (typep x 'pointer) - (typep y 'pointer))) - nil - (macrolet ((test (accessor &rest args) - `(objects-equalp (,accessor x ,@args) - (,accessor y ,@args)))) - (typecase x - (bignum - (= x y)) - (function - (and (test funobj-code-vector) - (test funobj-code-vector%1op) - (test funobj-code-vector%2op) - (test funobj-code-vector%3op) - (test funobj-lambda-list) - (test funobj-name) - (test funobj-num-constants) - (test funobj-num-jumpers) - (dotimes (i (funobj-num-constants x) t) - (unless (test funobj-constant-ref i))))) - (symbol - (and (test memref #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::function-value) - 0 :lisp) - (test memref #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::name) - 0 :lisp) - (test memref #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::flags) - 0 :lisp))) - (vector - (and (typep y 'vector) - (test array-element-type) - (every #'objects-equalp x y))) - (cons - (and (typep y 'cons) - (test car) - (test cdr))) - (structure-object - (and (typep y 'structure-object) - (test structure-object-class) - (test structure-object-length) - (dotimes (i (structure-object-length x) t) - (unless (test structure-ref i) - (return nil))))) - (std-instance - (and (typep y 'std-instance) - (test std-instance-class) - (test std-instance-slots)))))))) + (cond + ((not (objects-equalp (class-of x) (class-of y))) + nil) + ((not (and (typep x 'pointer) + (typep y 'pointer))) + nil) + (t (macrolet ((test (accessor &rest args) + `(objects-equalp (,accessor x ,@args) + (,accessor y ,@args)))) + (typecase x + (bignum + (= x y)) + (function + (and (test funobj-code-vector) + (test funobj-code-vector%1op) + (test funobj-code-vector%2op) + (test funobj-code-vector%3op) + (test funobj-lambda-list) + (test funobj-name) + (test funobj-num-constants) + (test funobj-num-jumpers) + (dotimes (i (funobj-num-constants x) t) + (unless (test funobj-constant-ref i))))) + (symbol + (and (test memref #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::function-value) + 0 :lisp) + (test memref #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::name) + 0 :lisp) + (test memref #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::flags) + 0 :lisp))) + (vector + (and (typep y 'vector) + (test array-element-type) + (every #'objects-equalp x y))) + (cons + (and (typep y 'cons) + (test car) + (test cdr))) + (structure-object + (and (typep y 'structure-object) + (test structure-object-class) + (test structure-object-length) + (dotimes (i (structure-object-length x) t) + (unless (test structure-ref i) + (return nil))))) + (std-instance + (and (typep y 'std-instance) + (test std-instance-class) + (test std-instance-slots))))))))) (define-compiler-macro %lispval-object (integer &environment env) "Return the object that is wrapped in the 32-bit integer lispval." @@ -312,33 +372,57 @@ #.(movitz::movitz-type-word-size :movitz-struct) (* 2 (truncate (+ (structure-object-length object) 1) 2)))))))) - -(defun copy-control-stack (&key (relative-uplinks t) - (stack (%run-time-context-slot 'stack-vector)) - (frame (current-stack-frame))) - (assert (location-in-object-p stack frame)) - (let* ((stack-start-location (+ 2 (object-location stack))) - (frame-index (- frame stack-start-location)) - (copy (subseq stack frame-index)) - (copy-start-location (+ 2 (object-location copy))) - (cc (subseq copy 0))) - (do ((i 0)) (nil) - (let ((uplink-frame (svref%unsafe copy i))) - (cond - ((= 0 uplink-frame) - (setf (svref%unsafe copy i) 0) - (return (values copy cc))) - (t (let ((uplink-index (- uplink-frame stack-start-location frame-index))) - (assert (< -1 uplink-index (length copy)) () - "Uplink-index outside copy: ~S, i: ~S" uplink-index i) - (setf (svref%unsafe copy i) - (if relative-uplinks - uplink-index - (let ((x (+ uplink-index copy-start-location))) - (assert (= copy-start-location (+ 2 (object-location copy))) () - "Destination stack re-located!") - (assert (location-in-object-p copy x) () - "Bad uplink ~S computed from index ~S and copy ~Z, csl: ~S" - x uplink-index copy copy-start-location) - x))) - (setf i uplink-index)))))))) +(defun current-control-stack-depth (&optional (start-frame (current-stack-frame))) + "How deep is the stack currently?" + (do ((frame start-frame (stack-frame-uplink nil frame))) + ((eq 0 (stack-frame-uplink nil frame)) + (1+ (- frame start-frame))))) + +(defun copy-current-control-stack (&optional (start-frame (current-stack-frame))) + (let ((copy (make-array (current-control-stack-depth start-frame) + :element-type '(unsigned-byte 32)))) + (dotimes (i (length copy)) + (setf (stack-frame-ref copy i 0 :unsigned-byte32) + (stack-frame-ref nil start-frame i :unsigned-byte32))) + (do ((frame start-frame)) + ((eq 0 frame)) + (let ((uplink (stack-frame-uplink nil frame))) + (setf (stack-frame-ref copy 0 (- frame start-frame) :lisp) + (if (eql 0 uplink) + 0 + (- uplink start-frame))) + (setf frame uplink))) + copy)) + +;;; (let* ((stack-start-location (+ 2 (object-location stack))) +;;; (start-frame-index (- start-frame stack-start-location)) +;;; (copy (subseq stack start-frame-index)) +;;; (copy-start-location (+ 2 (object-location copy)))) +;;; (do ((frame start-frame-index) +;;; (index 0)) +;;; (nil) +;;; (let ((uplink-frame (stack-frame-uplink stack frame))) +;;; (cond +;;; ((= 0 uplink-frame) +;;; (setf (svref%unsafe copy index) 0) +;;; (return copy)) +;;; (t (let* ((uplink-frame (- uplink-frame stack-start-location)) +;;; (uplink-index (- uplink-frame start-frame-index))) +;;; (warn "~S uf ~S [~S]" +;;; (+ frame stack-start-location) +;;; (+ uplink-frame stack-start-location) +;;; frame) +;;; (assert (< -1 uplink-index (length copy)) () +;;; "Uplink-index outside copy: ~S, uplink-frame: ~S frame: ~S, index: ~S" +;;; uplink-index uplink-frame (+ frame stack-start-location) index) +;;; (setf (svref%unsafe copy index) +;;; (if relative-uplinks +;;; uplink-index +;;; (let ((x (+ uplink-index copy-start-location))) +;;; (assert (= copy-start-location (+ 2 (object-location copy))) () +;;; "Destination stack re-located!") +;;; (assert (location-in-object-p copy x) () +;;; "Bad uplink ~S computed from index ~S and copy ~Z, csl: ~S" +;;; x uplink-index copy copy-start-location) +;;; x))) +;;; (setf frame uplink-frame index uplink-index)))))))) Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.93 movitz/losp/muerte/integers.lisp:1.94 --- movitz/losp/muerte/integers.lisp:1.93 Wed Aug 18 11:50:33 2004 +++ movitz/losp/muerte/integers.lisp Wed Sep 15 12:22:59 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.93 2004/08/18 09:50:33 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.94 2004/09/15 10:22:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -90,16 +90,16 @@ ;; Now we have to make the compare act as unsigned, which is why ;; we compare zero-extended 16-bit quantities. (:movzxw (:ebx :edx (:offset movitz-bignum bigit0 2)) :ecx) ; First compare upper 16 bits. - (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) + (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) (:movzxw (:eax :edx (:offset movitz-bignum bigit0 2)) :ecx) - (:locally (:cmpl (:edi (:edi-offset scratch0)) :ecx)) + (:locally (:cmpl (:edi (:edi-offset raw-scratch0)) :ecx)) (:jne 'upper-16-decisive) (:movzxw (:ebx :edx (:offset movitz-bignum bigit0)) :ecx) ; Then compare lower 16 bits. - (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) + (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) (:movzxw (:eax :edx (:offset movitz-bignum bigit0)) :ecx) ; Then compare lower 16 bits. - (:locally (:cmpl (:edi (:edi-offset scratch0)) :ecx)) + (:locally (:cmpl (:edi (:edi-offset raw-scratch0)) :ecx)) upper-16-decisive (:ret) @@ -125,16 +125,16 @@ ;; we compare zero-extended 16-bit quantities. (:movzxw (:ebx :edx (:offset movitz-bignum bigit0 2)) :ecx) ; First compare upper 16 bits. - (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) + (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) (:movzxw (:eax :edx (:offset movitz-bignum bigit0)) :ecx) - (:locally (:cmpl :ecx (:edi (:edi-offset scratch0)))) + (:locally (:cmpl :ecx (:edi (:edi-offset raw-scratch0)))) (:jne 'negative-upper-16-decisive) (:movzxw (:ebx :edx (:offset movitz-bignum bigit0)) :ecx) ; Then compare lower 16 bits. - (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) + (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) (:movzxw (:eax :edx (:offset movitz-bignum bigit0)) :ecx) ; Then compare lower 16 bits. - (:locally (:cmpl :ecx (:edi (:edi-offset scratch0)))) + (:locally (:cmpl :ecx (:edi (:edi-offset raw-scratch0)))) negative-upper-16-decisive (:ret)))) (do-it))) @@ -1303,26 +1303,29 @@ (:movl (:ebx ,movitz:+other-type-offset+) :ecx) (:movl :ecx (:eax ,movitz:+other-type-offset+)) (:shrl 16 :ecx) + (:testb 3 :cl) + (:jnz '(:sub-program () (:int 63))) + (:movl :ecx :esi) (:xorl :edx :edx) ; edx=hi-digit=0 ; eax=lo-digit=msd(number) + (:compile-form (:result-mode :ecx) divisor) + (:shrl ,movitz:+movitz-fixnum-shift+ :ecx) (:std) - (:compile-form (:result-mode :esi) divisor) - (:shrl ,movitz:+movitz-fixnum-shift+ :esi) divide-loop (:load-lexical (:lexical-binding number) :ebx) - (:movl (:ebx :ecx (:offset movitz-bignum bigit0 -4)) + (:movl (:ebx :esi (:offset movitz-bignum bigit0 -4)) :eax) - (:divl :esi :eax :edx) + (:divl :ecx :eax :edx) (:load-lexical (:lexical-binding r) :ebx) - (:movl :eax (:ebx :ecx (:offset movitz-bignum bigit0 -4))) - (:subl 4 :ecx) + (:movl :eax (:ebx :esi (:offset movitz-bignum bigit0 -4))) + (:subl 4 :esi) (:jnz 'divide-loop) (:movl :edi :eax) ; safe value (:leal ((:edx ,movitz:+movitz-fixnum-factor+)) :edx) - (:movl (:ebp -4) :esi) (:cld) + (:movl (:ebp -4) :esi) (:movl :ebx :eax) (:movl :edx :ebx) Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.22 movitz/losp/muerte/interrupt.lisp:1.23 --- movitz/losp/muerte/interrupt.lisp:1.22 Thu Sep 2 11:45:26 2004 +++ movitz/losp/muerte/interrupt.lisp Wed Sep 15 12:22:59 2004 @@ -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.22 2004/09/02 09:45:26 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.23 2004/09/15 10:22:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -20,16 +20,22 @@ (defvar *last-dit-frame* nil) -(defun dit-frame-esp (dit-frame) - (+ dit-frame 6)) - (defconstant +dit-frame-map+ - '(nil :eflags :eip :error-code :exception-vector :ebp :funobj + '(nil :eflags :eip :error-code :exception-vector + :ebp + :funobj :edi :atomically-status :atomically-esp - :scratch0 - :ecx :eax :edx :ebx :esi)) + :raw-scratch0 + :ecx :eax :edx :ebx :esi + :scratch1)) + + +(defun dit-frame-esp (stack dit-frame) + "Return the frame ESP pointed to when interrupt at dit-frame occurred." + (declare (ignore stack)) + (+ dit-frame 6)) (define-compiler-macro dit-frame-index (&whole form name &environment env) (let ((name (and (movitz:movitz-constantp name env) @@ -44,28 +50,37 @@ (defun dit-frame-offset (name) (* 4 (dit-frame-index name)))) -(define-compiler-macro dit-frame-ref (&whole form reg type - &optional (offset 0) - (frame '*last-dit-frame*) - &environment env) - `(memref ,frame (+ (dit-frame-offset ,reg) ,offset) 0 ,type)) +(define-compiler-macro dit-frame-ref (&whole form stack frame reg + &optional (type :lisp) + &environment env) + (if (not (and (movitz:movitz-constantp stack env) + (eq nil (movitz:movitz-eval stack env)))) + form + `(memref ,frame (dit-frame-offset ,reg) 0 ,type))) -(defun dit-frame-ref (reg type &optional (offset 0) (frame *last-dit-frame*)) - (dit-frame-ref reg type offset frame)) +(defun dit-frame-ref (stack frame reg &optional (type :lisp)) + (stack-frame-ref stack frame (dit-frame-index reg) type)) -(defun (setf dit-frame-ref) (x reg type &optional (frame *last-dit-frame*)) - (setf (memref frame (dit-frame-offset reg) 0 type) x)) +;;;(defun (setf dit-frame-ref) (x reg type &optional (frame *last-dit-frame*)) +;;; (setf (memref frame (dit-frame-offset reg) 0 type) x)) -(defun dit-frame-casf (dit-frame) +(defun dit-frame-casf (stack dit-frame) "Compute the `currently active stack-frame' when the interrupt occurred." - (let ((ebp (dit-frame-ref :ebp :lisp 0 dit-frame)) - (esp (dit-frame-esp dit-frame))) - (if (< esp ebp) - ebp - (let ((next-ebp (memref ebp 0 0 :lisp))) + (let ((ebp (dit-frame-ref stack dit-frame :ebp)) + (esp (dit-frame-esp stack dit-frame))) + (cond + ((< esp ebp) + ebp) + ((> esp ebp) + ;; A throw situation + (let ((next-ebp (stack-frame-ref stack esp 0))) (check-type next-ebp fixnum) (assert (< esp next-ebp)) - next-ebp)))) + next-ebp)) + (t (let ((next-ebp (stack-frame-ref stack esp 0))) + (check-type next-ebp fixnum) + (assert (< esp next-ebp)) + next-ebp))))) (define-primitive-function (default-interrupt-trampoline :symtab-property t) () "Default first-stage/trampoline interrupt handler. Assumes the IF flag in EFLAGS @@ -92,17 +107,26 @@ (:pushl :ebp) (:movl :esp :ebp) (:pushl 0) ; 0 'funobj' means default-interrupt-trampoline frame - (:pushl :edi) ; -28 + (:pushl :edi) ; (:movl ':nil-value :edi) ; We want NIL! (:locally (:pushl (:edi (:edi-offset atomically-status)))) (:locally (:pushl (:edi (:edi-offset atomically-esp)))) - (:locally (:pushl (:edi (:edi-offset scratch0)))) + (:locally (:pushl (:edi (:edi-offset raw-scratch0)))) ,@(loop for reg in (sort (copy-list '(:eax :ebx :ecx :edx :esi)) #'> :key #'dit-frame-index) collect `(:pushl ,reg)) + (:locally (:pushl (:edi (:edi-offset scratch1)))) (:locally (:movl 0 (:edi (:edi-offset atomically-status)))) + +;;; ;; See if ESP/EBP signalled a throwing situation +;;; (:leal (:ebp 24) :edx) ; Interrupted ESP +;;; (:cmpl :edx (:ebp)) ; cmp ESP EBP +;;; (:jae 'not-throwing) +;;; (:movl (:edx) :edx) +;;; (:movl :edx (:ebp)) +;;; not-throwing ;; rearrange stack for return (:movl (:ebp 12) :eax) ; load return address @@ -166,8 +190,10 @@ (:locally (:movl :ecx (:edi (:edi-offset atomically-status)))) (:movl (:ebp ,(dit-frame-offset :atomically-esp)) :ecx) (:locally (:movl :ecx (:edi (:edi-offset atomically-esp)))) - (:movl (:ebp ,(dit-frame-offset :scratch0)) :ecx) - (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) + (:movl (:ebp ,(dit-frame-offset :raw-scratch0)) :ecx) + (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) + (:movl (:ebp ,(dit-frame-offset :scratch1)) :eax) + (:locally (:movl :eax (:edi (:edi-offset scratch1)))) (:movl (:ebp ,(dit-frame-offset :edi)) :edi) (:movl (:ebp ,(dit-frame-offset :esi)) :esi) (:movl (:ebp ,(dit-frame-offset :ebx)) :ebx) @@ -296,7 +322,7 @@ (6 (error "Illegal instruction at ~@Z." $eip)) (13 (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z" $eip - (dit-frame-ref :error-code :unsigned-byte32 0 dit-frame) + (dit-frame-ref nil dit-frame :error-code :unsigned-byte32) $eax $ebx $ecx)) ((60) ;; EAX failed type in EDX. May be restarted by returning with a new value in EAX. @@ -328,10 +354,13 @@ (stack-left (- old-bottom real-bottom)) (old-dynamic-env (%run-time-context-slot 'dynamic-env)) (new-bottom (cond - ((< stack-left 10) + ((< stack-left 50) (princ "Halting CPU due to stack exhaustion.") (halt-cpu)) - ((<= stack-left 256) + ((<= stack-left 1024) + (backtrace :print-frames t) + (halt-cpu) + #+ignore (format *debug-io* "~&This is your LAST chance to pop off stack.~%") real-bottom) @@ -366,13 +395,12 @@ (error 'unbound-variable :name name)))) ((100);; 101 102 103 104 105) (let ((funobj (dereference (+ dit-frame (dit-frame-index :esi)))) - (code (dit-frame-ref :ecx :unsigned-byte8 0 dit-frame))) + (code (dit-frame-ref nil dit-frame :ecx :unsigned-byte8))) (error 'wrong-argument-count :function funobj :argument-count (if (logbitp 7 code) - (ash (dit-frame-ref :ecx :unsigned-byte32 - 0 dit-frame) - -24) + (ldb (byte 8 24) + (dit-frame-ref nil dit-frame :ecx :unsigned-byte32)) code)))) (108 (error 'throw-error :tag (dereference $eax))) Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.28 movitz/losp/muerte/memref.lisp:1.29 --- movitz/losp/muerte/memref.lisp:1.28 Thu Sep 2 11:38:46 2004 +++ movitz/losp/muerte/memref.lisp Wed Sep 15 12:22:59 2004 @@ -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.28 2004/09/02 09:38:46 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.29 2004/09/15 10:22:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -316,12 +316,13 @@ (defun memref (object offset index type) (ecase type + (:lisp (memref object offset index :lisp)) + (:unsigned-byte32 (memref object offset index :unsigned-byte32)) + (:character (memref object offset index :character)) (:unsigned-byte8 (memref object offset index :unsigned-byte8)) + (:location (memref object offset index :location)) (:unsigned-byte14 (memref object offset index :unsigned-byte14)) (:unsigned-byte16 (memref object offset index :unsigned-byte16)) - (:unsigned-byte32 (memref object offset index :unsigned-byte32)) - (:character (memref object offset index :character)) - (:lisp (memref object offset index :lisp)) (:signed-byte30+2 (memref object offset index :signed-byte30+2)) (:unsigned-byte29+3 (memref object offset index :unsigned-byte29+3)))) @@ -337,7 +338,7 @@ (movitz:movitz-constantp offset env) (movitz:movitz-constantp index env)) (let ((value (movitz:movitz-eval value env))) - (check-type value movitz-character) + (check-type value movitz::movitz-character) `(progn (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ebx) ,object) @@ -667,63 +668,66 @@ movitz:*compiler-physical-segment-prefix*))) (ecase (movitz::eval-form type) (:lisp - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :push) ,address) - (:compile-form (:result-mode :push) ,offset) - (:compile-form (:result-mode :ecx) ,index) - (:popl :ebx) ; offset - (:popl :eax) ; address - (:shll 2 :ecx) - (:addl :ecx :eax) - (:addl :ebx :eax) - (:shrl ,movitz::+movitz-fixnum-shift+ :eax) - (,prefixes :movl (:eax) :eax))) - (:unsigned-byte8 - `(with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-form (:result-mode :push) ,address) - (:compile-form (:result-mode :push) ,offset) - (:compile-form (:result-mode :ecx) ,index) - (:popl :eax) ; offset - (:popl :ebx) ; address - (:addl :ecx :ebx) ; add index - (:addl :eax :ebx) ; add offset - (:xorl :eax :eax) - (:shrl ,movitz::+movitz-fixnum-shift+ :ebx) ; scale down address - (,prefixes :movb (:ebx) :al))) + (let ((address-var (gensym "memref-int-address-"))) + `(let ((,address-var ,address)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ecx) ,offset ,index) + (:load-lexical (:lexical-binding ,address-var) :ebx) + (:shll 2 :ecx) + (:addl :ebx :eax) + (:into) + (:testb ,(mask-field (byte (+ 2 movitz::+movitz-fixnum-shift+) 0) -1) + :al) + (:jnz '(:sub-program () (:int 63))) + (:addl :eax :ecx) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale down address + (,prefixes :movl (:ecx) :eax))))) (:unsigned-byte32 - `(with-inline-assembly (:returns :eax) - (:compile-form (:result-mode :push) ,address) - (:compile-two-forms (:eax :ecx) ,offset ,index) - (:popl :ebx) ; address - (:shll 2 :ecx) - (:addl :ebx :eax) - (:into) - (:testb ,(mask-field (byte (+ 2 movitz::+movitz-fixnum-shift+) 0) -1) - :al) - (:jnz '(:sub-program () (:int 63))) - (:addl :ecx :eax) - (:shrl ,movitz::+movitz-fixnum-shift+ :eax) ; scale down address - (,prefixes :movl (:eax) :ecx) - (:call-local-pf box-u32-ecx))) + (let ((address-var (gensym "memref-int-address-"))) + `(let ((,address-var ,address)) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-two-forms (:eax :ecx) ,offset ,index) + (:load-lexical (:lexical-binding ,address-var) :ebx) + (:shll 2 :ecx) + (:addl :ebx :eax) + (:into) + (:testb ,(mask-field (byte (+ 2 movitz::+movitz-fixnum-shift+) 0) -1) + :al) + (:jnz '(:sub-program () (:int 63))) + (:addl :eax :ecx) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale down address + (,prefixes :movl (:ecx) :ecx))))) + (:unsigned-byte8 + (cond + ((and (eq 0 offset) (eq 0 index)) + `(with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-form (:result-mode :untagged-fixnum-ecx) ,address) + (,prefixes :movzxw (:ecx) :ecx))) + (t (let ((address-var (gensym "memref-int-address-"))) + `(let ((,address-var ,address)) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-two-forms (:eax :ecx) ,offset ,index) + (:load-lexical (:lexical-binding ,address-var) :ebx) + (:addl :eax :ecx) + (:addl :ebx :ecx) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale down address + (,prefixes :movzxw (:ecx) :ecx))))))) (:unsigned-byte16 (cond ((and (eq 0 offset) (eq 0 index)) - `(with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-form (:result-mode :ebx) ,address) - (:xorl :eax :eax) - (:shrl ,movitz::+movitz-fixnum-shift+ :ebx) ; scale down address - (,prefixes :movw (:ebx (:ecx 2)) :ax))) - (t `(with-inline-assembly (:returns :untagged-fixnum-eax) - (:compile-form (:result-mode :push) ,address) - (:compile-form (:result-mode :push) ,offset) - (:compile-form (:result-mode :ecx) ,index) - (:popl :eax) ; offset - (:popl :ebx) ; address - (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale index - (:addl :eax :ebx) ; add offset - (:xorl :eax :eax) - (:shrl ,movitz::+movitz-fixnum-shift+ :ebx) ; scale down address - (,prefixes :movw (:ebx (:ecx 2)) :ax))))))))) + `(with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-form (:result-mode :untagged-fixnum-ecx) ,address) + (,prefixes :movzxw (:ecx) :ecx))) + (t (let ((address-var (gensym "memref-int-address-"))) + `(let ((,address-var ,address)) + (with-inline-assembly (:returns :untagged-fixnum-ecx) + (:compile-two-forms (:eax :ecx) ,offset ,index) + (:load-lexical (:lexical-binding ,address-var) :ebx) + (:shll 1 :ecx) ; scale index + (:addl :eax :ecx) + (:addl :ebx :ecx) + (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) ; scale down address + (,prefixes :movzxw (:ecx) :ecx))))))))))) (defun memref-int (address offset index type &optional physicalp) (cond Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.18 movitz/losp/muerte/more-macros.lisp:1.19 --- movitz/losp/muerte/more-macros.lisp:1.18 Mon Aug 23 15:49:40 2004 +++ movitz/losp/muerte/more-macros.lisp Wed Sep 15 12:22:59 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.18 2004/08/23 13:49:40 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.19 2004/09/15 10:22:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -341,15 +341,15 @@ `(with-inline-assembly (:returns :untagged-fixnum-ecx) (:locally (:movl (:edi (:edi-offset ,slot-name)) :ecx)))))))) -(define-compiler-macro malloc-pointer-words (words) - `(with-inline-assembly (:returns :eax :type pointer) - (:compile-form (:result-mode :eax) ,words) - (:call-local-pf malloc-pointer-words))) - -(define-compiler-macro malloc-non-pointer-words (words) - `(with-inline-assembly (:returns :eax :type pointer) - (:compile-form (:result-mode :eax) ,words) - (:call-local-pf malloc-non-pointer-words))) +;;;(define-compiler-macro malloc-pointer-words (words) +;;; `(with-inline-assembly (:returns :eax :type pointer) +;;; (:compile-form (:result-mode :eax) ,words) +;;; (:call-local-pf malloc-pointer-words))) +;;; +;;;(define-compiler-macro malloc-non-pointer-words (words) +;;; `(with-inline-assembly (:returns :eax :type pointer) +;;; (:compile-form (:result-mode :eax) ,words) +;;; (:call-local-pf malloc-non-pointer-words))) (define-compiler-macro read-time-stamp-counter () `(with-inline-assembly-case () Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.41 movitz/losp/muerte/primitive-functions.lisp:1.42 --- movitz/losp/muerte/primitive-functions.lisp:1.41 Thu Sep 2 11:21:31 2004 +++ movitz/losp/muerte/primitive-functions.lisp Wed Sep 15 12:22:59 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.41 2004/09/02 09:21:31 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.42 2004/09/15 10:22:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -321,54 +321,56 @@ (:leal (:eax :ecx 6) :eax) (:ret))) -(define-primitive-function malloc-non-pointer-words () - "Stupid allocator.. Number of words in EAX/fixnum. -Result in EAX, with tag 6." - (with-inline-assembly (:returns :multiple-values) - (:movl :eax :ebx) - (:locally (:movl (:edi (:edi-offset nursery-space)) :eax)) - (:testb #xff :al) - (:jnz '(:sub-program (not-initialized) - (:int 110) - (:halt) - (:jmp 'not-initialized))) - (:addl 7 :ebx) - (:andb #xf8 :bl) - (:movl (:eax 4) :ecx) ; cons pointer to ECX - (:leal (:ebx :ecx) :edx) ; new roof to EDX - (:cmpl :edx (:eax)) ; end of buffer? - (:jl '(:sub-program (failed) - (:int 112) - (:halt) - (:jmp 'failed))) - (:movl :edx (:eax 4)) ; new cons pointer - (:leal (:eax :ecx 6) :eax) - (:ret))) - -(defun malloc-pointer-words (words) - (check-type words (integer 2 *)) - (compiler-macro-call malloc-pointer-words words)) - -(defun malloc-non-pointer-words (words) - (check-type words (integer 2 *)) - (compiler-macro-call malloc-non-pointer-words words)) +;;;(define-primitive-function malloc-non-pointer-words () +;;; "Stupid allocator.. Number of words in EAX/fixnum. +;;;Result in EAX, with tag 6." +;;; (with-inline-assembly (:returns :multiple-values) +;;; (:movl :eax :ebx) +;;; (:locally (:movl (:edi (:edi-offset nursery-space)) :eax)) +;;; (:testb #xff :al) +;;; (:jnz '(:sub-program (not-initialized) +;;; (:int 110) +;;; (:halt) +;;; (:jmp 'not-initialized))) +;;; (:addl 7 :ebx) +;;; (:andb #xf8 :bl) +;;; (:movl (:eax 4) :ecx) ; cons pointer to ECX +;;; (:leal (:ebx :ecx) :edx) ; new roof to EDX +;;; (:cmpl :edx (:eax)) ; end of buffer? +;;; (:jl '(:sub-program (failed) +;;; (:int 112) +;;; (:halt) +;;; (:jmp 'failed))) +;;; (:movl :edx (:eax 4)) ; new cons pointer +;;; (:leal (:eax :ecx 6) :eax) +;;; (:ret))) (define-primitive-function get-cons-pointer () "Return in EAX the next object location with space for EAX words, with tag 6. Preserve ECX." (macrolet ((do-it () - ;; Here we just call malloc, and don't care if the allocation - ;; is never comitted. `(with-inline-assembly (:returns :multiple-values) - ;; We need a stack-frame sice we're using the stack - (:pushl :ebp) - (:movl :esp :ebp) - (:pushl 4) - (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) - (:call-local-pf malloc-pointer-words) - (:locally (:movl (:edi (:edi-offset scratch0)) :ecx)) - (:leave) + (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) ; Preserve ECX + (:movl :eax :ebx) + (:locally (:movl (:edi (:edi-offset nursery-space)) :eax)) + (:testb #xff :al) + (:jnz '(:sub-program (not-initialized) + (:int 110) + (:halt) + (:jmp 'not-initialized))) + (:addl 4 :ebx) + (:andb #xf8 :bl) + (:movl (:eax 4) :ecx) ; cons pointer to ECX + (:leal (:ebx :ecx) :edx) ; new roof to EDX + (:cmpl :edx (:eax)) ; end of buffer? + (:jl '(:sub-program (failed) + (:int 112) + (:halt) + (:jmp 'failed))) + (:movl :edx (:eax 4)) ; new cons pointer + (:leal (:eax :ecx 6) :eax) + (:locally (:movl (:edi (:edi-offset raw-scratch0)) :ecx)) (:ret)))) (do-it))) @@ -383,6 +385,18 @@ (:ret)))) (do-it))) +(define-primitive-function get-cons-pointer-non-pointer () + "Return in EAX the next object location with space for EAX non-pointer words, with tag 6. +Preserve ECX." + (with-inline-assembly (:returns :multiple-values) + (:locally (:jmp (:edi (:edi-offset get-cons-pointer)))))) + +(define-primitive-function cons-commit-non-pointer () + "Return in EAX the next object location with space for EAX non-pointer words, with tag 6. +Preserve ECX." + (with-inline-assembly (:returns :multiple-values) + (:locally (:jmp (:edi (:edi-offset cons-commit)))))) + (defun malloc-initialize (buffer-start buffer-size) "BUFFER-START is the location from which to allocate. BUFFER-SIZE is the number of words in the buffer." @@ -468,16 +482,9 @@ (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) (:ret) not-fixnum - (:locally (:movl :ecx (:edi (:edi-offset scratch0)))) ; Save value for later - (:movl ,(* 2 movitz:+movitz-fixnum-factor+) :eax) - (:call-local-pf malloc-non-pointer-words) - (:movl ,(dpb movitz:+movitz-fixnum-factor+ - (byte 16 16) - (movitz:tag :bignum 0)) - (:eax ,movitz:+other-type-offset+)) - (:locally (:movl (:edi (:edi-offset scratch0)) :ecx)) ; Restore value - (:movl :ecx (:eax ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0))) - (:ret)))) + ;; XXX Implement bignum consing here. + fail + (:int 63)))) (do-it))) Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.28 movitz/losp/muerte/scavenge.lisp:1.29 --- movitz/losp/muerte/scavenge.lisp:1.28 Thu Sep 2 11:41:09 2004 +++ movitz/losp/muerte/scavenge.lisp Wed Sep 15 12:22:59 2004 @@ -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.28 2004/09/02 09:41:09 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.29 2004/09/15 10:22:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -27,7 +27,8 @@ ;; circumstances, i.e. when you know there is no outside GC ;; etc. involved. -(defvar *scan*) +(defvar *scan*) ; debugging +(defvar *scan-last*) ; debugging (defvar *map-heap-words-verbose* nil) (defun map-heap-words (function start-location end-location) @@ -45,95 +46,102 @@ (*scan-last* nil) ; Last scanned object, for debugging. (scan start-location (1+ scan))) ((>= scan end-location)) - (declare (special *scan-last*)) - (let ((*scan* scan) - (x (memref scan 0 0 :unsigned-byte16))) - (declare (special *scan*)) - (when verbose - (format *terminal-io* " [at ~S: ~S]" scan x)) - (cond - ((let ((tag (ldb (byte 3 0) x))) - (or (= tag #.(movitz:tag :null)) - (= tag #.(movitz:tag :fixnum)) - (scavenge-typep x :character)))) - ((scavenge-typep x :illegal) - (error "Illegal word ~S at ~S." x scan)) - ((scavenge-typep x :bignum) - (assert (evenp scan) () - "Scanned ~S at odd location #x~X." x scan) - ;; Just skip the bigits - (let* ((bigits (memref scan 0 1 :unsigned-byte14)) - (delta (logior bigits 1))) + (with-simple-restart (continue-map-heap-words + "Continue map-heap-words at location ~S." (1+ scan)) + (let ((*scan* scan) + (x (memref scan 0 0 :unsigned-byte16))) + (declare (special *scan*)) + (when verbose + (format *terminal-io* " [at ~S: ~S]" scan x)) + (cond + ((let ((tag (ldb (byte 3 0) x))) + (or (= tag #.(movitz:tag :null)) + (= tag #.(movitz:tag :fixnum)) + (scavenge-typep x :character)))) + ((scavenge-typep x :illegal) + (error "Illegal word ~S at ~S." x scan)) + ((scavenge-typep x :bignum) + (assert (evenp scan) () + "Scanned bignum-header ~S at odd location #x~X." x scan) + ;; Just skip the bigits + (let* ((bigits (memref scan 0 1 :unsigned-byte14)) + (delta (logior bigits 1))) + (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) + (incf scan delta))) + ((scavenge-typep x :defstruct) + (assert (evenp scan) () + "Scanned struct-header ~S at odd location #x~X." x scan) + (setf *scan-last* (%word-offset scan #.(movitz:tag :other)))) + ((scavenge-typep x :funobj) + (assert (evenp scan) () + "Scanned funobj-header ~S at odd location #x~X." + (memref scan 0 0 :unsigned-byte32) scan) (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) - (incf scan delta))) - ((scavenge-typep x :funobj) - (assert (evenp scan) () - "Scanned ~Z at odd location #x~X." x scan) - (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) - ;; Process code-vector pointers specially.. - (let* ((funobj (%word-offset scan #.(movitz:tag :other))) - (code-vector (funobj-code-vector funobj)) - (num-jumpers (funobj-num-jumpers funobj))) - (check-type code-vector code-vector) - (map-heap-words function (+ scan 5) (+ scan 7)) ; scan funobj's lambda-list and name - (let ((new-code-vector (funcall function code-vector scan))) - (check-type new-code-vector code-vector) - (unless (eq code-vector new-code-vector) - (error "Code-vector migration is not implemented.") - (setf (memref scan 0 -1 :lisp) (%word-offset new-code-vector 2)) - ;; Do more stuff here to update code-vectors and jumpers - )) - (incf scan (+ 7 num-jumpers)))) ; Don't scan the jumpers. - ((scavenge-typep x :infant-object) - (assert (evenp scan) () - "Scanned #x~Z at odd location #x~X." x scan) - (error "Scanning an infant object ~Z at ~S (end ~S)." x scan end-location)) - ((or (scavenge-wide-typep x :basic-vector - #.(bt:enum-value 'movitz:movitz-vector-element-type :u8)) - (scavenge-wide-typep x :basic-vector - #.(bt:enum-value 'movitz:movitz-vector-element-type :character)) - (scavenge-wide-typep x :basic-vector - #.(bt:enum-value 'movitz:movitz-vector-element-type :code))) - (assert (evenp scan) () - "Scanned ~Z at odd location #x~X." x scan) - (let ((len (memref scan 0 1 :lisp))) - (check-type len positive-fixnum) - (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) - (incf scan (1+ (* 2 (truncate (+ 7 len) 8)))))) - ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16)) - (assert (evenp scan) () - "Scanned ~Z at odd location #x~X." x scan) - (let ((len (memref scan 0 1 :lisp))) - (check-type len positive-fixnum) - (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) - (incf scan (1+ (* 2 (truncate (+ 3 len) 4)))))) - ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32)) - (assert (evenp scan) () - "Scanned ~Z at odd location #x~X." x scan) - (let ((len (memref scan 0 1 :lisp))) - (assert (typep len 'positive-fixnum) () - "Scanned basic-vector at ~S with illegal length ~S." scan len) - (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) - (incf scan (1+ (logand (1+ len) -2))))) - ((and (scavenge-typep x :basic-vector) - (not (scavenge-wide-typep x :basic-vector - #.(bt:enum-value 'movitz:movitz-vector-element-type :any-t)))) - (error "Scanned unknown basic-vector #x~Z at address #x~X." x scan)) - ((scavenge-typep x :old-vector) - (error "Scanned old-vector ~Z at address #x~X." x scan)) - ((eq x 3) - (incf scan) - (let ((delta (memref scan 0 0 :lisp))) - (check-type delta positive-fixnum) - ;; (warn "at ~S skipping ~S to ~S." scan delta (+ scan delta)) - (incf scan delta))) - (t ;; (typep x 'pointer) - (let* ((old (memref scan 0 0 :lisp)) - (new (funcall function old scan))) - (when verbose - (format *terminal-io* " [~Z => ~Z]" old new)) - (unless (eq old new) - (setf (memref scan 0 0 :lisp) new)))))))) + ;; Process code-vector pointers specially.. + (let* ((funobj (%word-offset scan #.(movitz:tag :other))) + (code-vector (funobj-code-vector funobj)) + (num-jumpers (funobj-num-jumpers funobj))) + (check-type code-vector code-vector) + (map-heap-words function (+ scan 5) (+ scan 7)) ; scan funobj's lambda-list and name + (let ((new-code-vector (funcall function code-vector scan))) + (check-type new-code-vector code-vector) + (unless (eq code-vector new-code-vector) + (error "Code-vector migration is not implemented.") + (setf (memref scan 0 -1 :lisp) (%word-offset new-code-vector 2)) + ;; Do more stuff here to update code-vectors and jumpers + )) + (incf scan (+ 7 num-jumpers)))) ; Don't scan the 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)) + ((or (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type :u8)) + (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type :character)) + (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type :code))) + (assert (evenp scan) () + "Scanned u8-vector-header ~S at odd location #x~X." x scan) + (let ((len (memref scan 0 1 :lisp))) + (check-type len positive-fixnum) + (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) + (incf scan (1+ (* 2 (truncate (+ 7 len) 8)))))) + ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u16)) + (assert (evenp scan) () + "Scanned u16-vector-header ~S at odd location #x~X." x scan) + (let ((len (memref scan 0 1 :lisp))) + (check-type len positive-fixnum) + (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) + (incf scan (1+ (* 2 (truncate (+ 3 len) 4)))))) + ((scavenge-wide-typep x :basic-vector #.(bt:enum-value 'movitz:movitz-vector-element-type :u32)) + (assert (evenp scan) () + "Scanned u32-vector-header ~S at odd location #x~X." x scan) + (let ((len (memref scan 0 1 :lisp))) + (assert (typep len 'positive-fixnum) () + "Scanned basic-vector at ~S with illegal length ~S." scan len) + (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) + (incf scan (1+ (logand (1+ len) -2))))) + ((scavenge-typep x :basic-vector) + (if (scavenge-wide-typep x :basic-vector + #.(bt:enum-value 'movitz:movitz-vector-element-type :any-t)) + (setf *scan-last* (%word-offset scan #.(movitz:tag :other))) + (error "Scanned unknown basic-vector-header ~S at location #x~X." x scan))) + ((scavenge-typep x :old-vector) + (error "Scanned old-vector ~Z at address #x~X." x scan)) + ((eq x 3) + (incf scan) + (let ((delta (memref scan 0 0 :lisp))) + (check-type delta positive-fixnum) + ;; (warn "at ~S skipping ~S to ~S." scan delta (+ scan delta)) + (incf scan delta))) + (t ;; (typep x 'pointer) + (let* ((old (memref scan 0 0 :lisp)) + (new (funcall function old scan))) + (when verbose + (format *terminal-io* " [~Z => ~Z]" old new)) + (unless (eq old new) + (setf (memref scan 0 0 :lisp) new))))))))) (values)) (defun map-stack-words (function stack start-frame) @@ -155,41 +163,65 @@ (stack-frame-ref stack frame 1 :unsigned-byte32) frame) (map-heap-words function (+ nether-frame 2) frame)) - ((eql 0) ; An dit interrupt-frame? + ((eql 0) ; A dit interrupt-frame? (let* ((dit-frame frame) - (casf-frame (dit-frame-casf dit-frame))) + (casf-frame (dit-frame-casf stack dit-frame))) ;; 1. Scavenge the dit-frame (cond - ((logbitp 10 (dit-frame-ref :eflags :unsigned-byte32 0 dit-frame)) + ((logbitp 10 (dit-frame-ref stack dit-frame :eflags :unsigned-byte32)) ;; DF flag was 1, so EAX and EDX are not GC roots. #+ignore (warn "Interrupt in uncommon mode at ~S" - (dit-frame-ref :eip :unsigned-byte32 0 dit-frame)) + (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) + #+ignore + (break "dit-frame: ~S, end: ~S" + dit-frame + (+ 1 dit-frame (dit-frame-index :ebx))) (map-heap-words function ; Assume nothing in the dit-frame above the location .. - (+ nether-frame 2) ; ..of EBX holds pointers. - (+ frame (dit-frame-index :ebx)))) + (+ nether-frame 2) ; ..of EDX holds pointers. + (+ dit-frame (dit-frame-index :edx)))) (t #+ignore (warn "Interrupt in COMMON mode!") (map-heap-words function ; Assume nothing in the dit-frame above the location .. (+ nether-frame 2) ; ..of ECX holds pointers. - (+ frame (dit-frame-index :ecx))))) + (+ dit-frame (dit-frame-index :ecx))))) ;; 2. Pop to (dit-)frame's CASF (setf nether-frame frame - frame (dit-frame-casf frame)) + frame (dit-frame-casf stack frame)) (let ((casf-funobj (funcall function (stack-frame-funobj stack frame) frame)) - (interrupted-esp (dit-frame-esp dit-frame))) + (interrupted-ebp (dit-frame-ref stack dit-frame :ebp)) + (interrupted-esp (dit-frame-esp stack dit-frame))) (cond ((eq nil casf-funobj) + #+ignore (warn "Scanning interrupt in PF: ~S" - (dit-frame-ref :eip :unsigned-byte32 0 dit-frame))) + (dit-frame-ref stack dit-frame :eip :unsigned-byte32))) ((eq 0 casf-funobj) (warn "Interrupt (presumably) in interrupt trampoline.")) ((typep casf-funobj 'function) (let ((casf-code-vector (funobj-code-vector casf-funobj))) ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. (cond + ((< interrupted-ebp interrupted-esp) + (cond + ((location-in-object-p casf-code-vector + (dit-frame-ref stack dit-frame :eip :location)) + #+ignore + (break "DIT at throw situation, in target EIP=~S" + (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) + (map-heap-words function interrupted-esp frame)) + ((location-in-object-p (funobj-code-vector (dit-frame-ref stack dit-frame + :scratch1)) + (dit-frame-ref stack dit-frame :eip :location)) + #+ignore + (break "DIT at throw situation, in thrower EIP=~S" + (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) + (map-heap-words function interrupted-esp frame)) + (t (error "DIT with EBP<ESP, EBP=~S, ESP=~S" + interrupted-ebp + interrupted-esp)))) ((location-in-object-p casf-code-vector - (dit-frame-ref :eip :location 0 dit-frame)) + (dit-frame-ref stack dit-frame :eip :location)) (cond ((let ((x0-tag (ldb (byte 3 0) (memref interrupted-esp 0 0 :unsigned-byte8)))) @@ -198,7 +230,7 @@ (memref interrupted-esp 0 0 :location)))) ;; When code-vector migration is implemented... (warn "Scanning at ~S X0 call ~S in ~S." - (dit-frame-ref :eip :unsigned-byte32 0 dit-frame) + (dit-frame-ref stack dit-frame :eip :unsigned-byte32) (memref interrupted-esp 0 0 :unsigned-byte32) (funobj-name casf-funobj)) (map-heap-words function (+ interrupted-esp 1) frame)) @@ -209,7 +241,7 @@ (memref interrupted-esp 0 1 :location)))) ;; When code-vector migration is implemented... (warn "Scanning at ~S X1 call ~S in ~S." - (dit-frame-ref :eip :unsigned-byte32 0 dit-frame) + (dit-frame-ref stack dit-frame :eip :unsigned-byte32) (memref interrupted-esp 0 1 :unsigned-byte32) (funobj-name casf-funobj)) (map-heap-words function (+ interrupted-esp 2) frame)) @@ -219,8 +251,8 @@ ;; Situation ii. esp(0)=CASF, esp(1)=code-vector (assert (location-in-object-p casf-code-vector (memref interrupted-esp 0 1 :location)) - () "Stack discipline situation ii. invariant broken. CASF=#x~X" - casf-frame) + () "Stack discipline situation ii. invariant broken. CASF=#x~X, ESP=~S, EBP=~S" + casf-frame interrupted-esp interrupted-ebp) (map-heap-words function (+ interrupted-esp 2) frame)) (t ;; Situation iii. esp(0)=code-vector. (assert (location-in-object-p casf-code-vector Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.36 movitz/losp/muerte/typep.lisp:1.37 --- movitz/losp/muerte/typep.lisp:1.36 Sun Aug 1 01:35:13 2004 +++ movitz/losp/muerte/typep.lisp Wed Sep 15 12:22:59 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.36 2004/07/31 23:35:13 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.37 2004/09/15 10:22:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -201,11 +201,14 @@ (symbol-not-nil (make-tag-typep :symbol)) (cons (make-tag-typep :cons)) + (tag0 (make-tag-typep :tag0)) + (tag1 (make-tag-typep :tag1)) (tag2 (make-tag-typep :tag2)) (tag3 (make-tag-typep :tag3)) (tag4 (make-tag-typep :tag4)) - (tag5 (make-tag-typep :null)) - (tag6 (make-tag-typep :other)) + (tag5 (make-tag-typep :tag5)) + (tag6 (make-tag-typep :tag6)) + (tag7 (make-tag-typep :tag7)) (basic-restart (make-tag-typep :basic-restart)) (pointer (assert (equal (mapcar 'movitz::tag '(:cons :other :symbol)) Index: movitz/losp/muerte/variables.lisp diff -u movitz/losp/muerte/variables.lisp:1.7 movitz/losp/muerte/variables.lisp:1.8 --- movitz/losp/muerte/variables.lisp:1.7 Thu Sep 2 11:46:14 2004 +++ movitz/losp/muerte/variables.lisp Wed Sep 15 12:22:59 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Nov 5 21:53:34 2003 ;;;; -;;;; $Id: variables.lisp,v 1.7 2004/09/02 09:46:14 ffjeld Exp $ +;;;; $Id: variables.lisp,v 1.8 2004/09/15 10:22:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -35,7 +35,7 @@ (defvar +++ nil) (defvar *read-base* 10) -(defvar *package*) +(defvar *package* nil) (defparameter *debugger-hook* nil) (defvar *active-condition-handlers* nil)

1 0

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

15 Sep '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv7579/losp Modified Files: los0-gc.lisp los0.lisp Log Message: many cleanup regarding stack and register discipline. Date: Wed Sep 15 12:22:58 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.35 movitz/losp/los0-gc.lisp:1.36 --- movitz/losp/los0-gc.lisp:1.35 Thu Sep 2 11:33:06 2004 +++ movitz/losp/los0-gc.lisp Wed Sep 15 12:22:57 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.35 2004/09/02 09:33:06 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.36 2004/09/15 10:22:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -146,7 +146,7 @@ retry (:locally (:cmpl 0 (:edi (:edi-offset atomically-status)))) ; Atomically? (:je '(:sub-program () - (:int 50))) ; This must be called inside atomically. + (:int 63))) ; This must be called inside atomically. (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) (:movl (:edx 2) :ebx) (:leal (:ebx :eax 4) :eax) @@ -205,6 +205,8 @@ (:jae '(:sub-program () (:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive) (:edi (:edi-offset atomically-status)))) + (:movl :edx (#x1000000)) + (:addl :eax (#x1000000)) (:int 113) ; This interrupt can be retried. (:jmp 'retry-cons))) (:movl ,(dpb movitz:+movitz-fixnum-factor+ @@ -239,9 +241,13 @@ (:movl :ebx :eax) ; Restore count in EAX before retry (:jmp 'retry))) (:movl :eax (:edx 2)) - (:movl ,(movitz:tag :infant-object) (:edx :ecx ,(+ 8 movitz:+other-type-offset+))) + (:movl ,(movitz:basic-vector-type-tag :any-t) + (:edx :ecx ,(+ 8 movitz:+other-type-offset+))) + (:subl 8 :ebx) + (:movl :ebx (:edx :ecx ,(+ 16 movitz:+other-type-offset+))) (:leal (:edx :ecx 8) :eax) (:xorl :ecx :ecx) + (:addl 8 :ecx) init-loop ; Now init ebx number of words (:movl :edi (:eax :ecx ,(- (movitz:tag :other)))) (:addl 4 :ecx) @@ -285,22 +291,22 @@ (setf (exception-handler 113) (lambda (exception interrupt-frame) (declare (ignore exception interrupt-frame)) - (let ((*standard-output* *terminal-io*)) - (when *gc-running* - (let ((muerte::*error-no-condition-for-debugger* t)) - (warn "Recursive GC triggered."))) - (let ((*gc-running* t)) - (unless *gc-quiet* - (format t "~&;; GC.. ")) - (stop-and-copy)) - (if *gc-break* - (break "GC break.") - (loop ; This is a nice opportunity to poll the keyboard.. - (case (muerte.x86-pc.keyboard:poll-char) - ((#\esc) - (break "Los0 GC keyboard poll.")) - ((nil) - (return)))))))) + (without-interrupts + (let ((*standard-output* *terminal-io*)) + (when *gc-running* + (break "Recursive GC triggered.")) + (let ((*gc-running* t)) + (unless *gc-quiet* + (format t "~&;; GC.. ")) + (stop-and-copy)) + (if *gc-break* + (break "GC break.") + (loop ; This is a nice opportunity to poll the keyboard.. + (case (muerte.x86-pc.keyboard:poll-char) + ((#\esc) + (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)))) @@ -315,8 +321,8 @@ (install-primitive los0-box-u32-ecx muerte::box-u32-ecx) (install-primitive los0-get-cons-pointer muerte::get-cons-pointer) (install-primitive los0-cons-commit muerte::cons-commit) - (install-primitive los0-malloc-pointer-words muerte::malloc-pointer-words) - (install-primitive los0-malloc-non-pointer-words muerte::malloc-non-pointer-words)) + #+ignore (install-primitive los0-malloc-pointer-words muerte::malloc-pointer-words) + #+ignore (install-primitive los0-malloc-non-pointer-words muerte::malloc-non-pointer-words)) (if (eq context (current-run-time-context)) (setf (%run-time-context-slot 'muerte::nursery-space) actual-duo-space) @@ -384,6 +390,10 @@ (check-type space0 vector-u32) (check-type space1 vector-u32) (assert (eq space0 (space-other space1))) + (assert (= 2 (space-fresh-pointer space1))) + (setf (%run-time-context-slot 'nursery-space) space1) + (values space1 space0) + #+ignore (multiple-value-bind (newspace oldspace) (if (< (space-fresh-pointer space0) ; Chose the emptiest space as newspace. (space-fresh-pointer space1)) @@ -403,23 +413,22 @@ nil) ((not (object-in-space-p oldspace x)) 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))) - (and (object-in-space-p newspace forwarded-x) - forwarded-x))) - (let ((forward-x (shallow-copy x))) - (when (and (typep x 'muerte::pointer) - *gc-consitency-check*) - (let ((a *x*)) - (vector-push (%object-lispval x) a) - (vector-push (memref (object-location x) 0 0 :unsigned-byte32) a) - (assert (vector-push (%object-lispval forward-x) a)))) - (setf (memref (object-location x) 0 0 :lisp) forward-x) - forward-x)))))))) - (setf *gc-stack* (muerte::copy-control-stack)) + (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))) + (and (object-in-space-p newspace forwarded-x) + forwarded-x))) + (let ((forward-x (shallow-copy x))) + (when (and (typep x 'muerte::pointer) + *gc-consitency-check*) + (let ((a *x*)) + (vector-push (%object-lispval x) a) + (vector-push (memref (object-location x) 0 0 :unsigned-byte32) a) + (assert (vector-push (%object-lispval forward-x) a)))) + (setf (memref (object-location x) 0 0 :lisp) forward-x) + forward-x)))))))) + (setf *gc-stack* (muerte::copy-current-control-stack)) ;; Scavenge roots (dolist (range muerte::%memory-map-roots%) (map-heap-words evacuator (car range) (cdr range))) @@ -470,5 +479,36 @@ ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%" old-size new-size (- old-size new-size)))) (initialize-space oldspace) - #+ignore (fill oldspace #x13 :start 2))) + (fill oldspace #x13 :start 2))) (values)) + + +(defun find-object-by-location (location &key (continuep t) (breakp nil)) + "Scan the heap for a (pointer) object that matches location. +This is a debugging tool." + (let ((results nil)) + (flet ((searcher (x ignore) + (declare (ignore ignore)) + (when (and (typep x '(or muerte::tag1 muerte::tag6 muerte::tag7)) + (not (eq x (%run-time-context-slot 'muerte::nursery-space))) + (location-in-object-p x location) + (not (member x results))) + (push x results) + (funcall (if breakp #'break #'warn) + "Found pointer ~Z of type ~S at location ~S." + x (type-of x) (object-location x))) + x)) + (handler-bind + ((serious-condition (lambda (c) + (when (and continuep + (find-restart 'muerte::continue-map-heap-words)) + (warn "Automatic continue from scanning error: ~A" c) + (invoke-restart 'muerte::continue-map-heap-words))))) + (dolist (range muerte::%memory-map-roots%) + (map-heap-words #'searcher (car range) (cdr range))) + (let ((nursery (%run-time-context-slot 'muerte::nursery-space))) + (map-heap-words #'searcher + (+ 4 (object-location nursery)) + (+ 4 (object-location nursery) (space-fresh-pointer nursery)))) + (map-stack-words #'searcher nil (current-stack-frame)))) + results)) Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.20 movitz/losp/los0.lisp:1.21 --- movitz/losp/los0.lisp:1.20 Wed Jul 28 16:15:17 2004 +++ movitz/losp/los0.lisp Wed Sep 15 12:22:57 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.20 2004/07/28 14:15:17 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.21 2004/09/15 10:22:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -46,8 +46,6 @@ (in-package muerte.init) -(declaim (special muerte::*multiboot-data*)) - (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. @@ -101,10 +99,12 @@ ;;; (values-list x) ;;; (warn "sym: ~S, stat: ~S" symbol status))) ;;; -;;;(defun test-loop (x) -;;; (format t "test-loop: ~S~%" -;;; (loop for i from 0 to 10 collect x))) -;;; + +#+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) @@ -133,6 +133,23 @@ (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 kumbo (&key a b (c (jumbo 1 2 3)) d) (print a) @@ -145,15 +162,34 @@ (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 (values) 'b (test-loop 1) (make-values) - 'c 'd 'e (make-no-values) 'f)) + '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 xx () (format t "wefewf") (with-inline-assembly (:returns :untagged-fixnum-ecx) @@ -162,10 +198,11 @@ (:leal (:edx :ecx 1) :ecx))) (defun xfoo (f) - (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" a b c d 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 @@ -215,6 +252,17 @@ (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))) + +(defun plus (a b) + (+ b a)) + +#+ignore (defun test-values () (multiple-value-bind (a b c d e f g h i j) (multiple-value-prog1 @@ -573,6 +621,11 @@ (let ((x (car p))) (print x)))) +(defun mubmo () + (let ((x (muerte::copy-funobj #'format)) + (y (cons 1 2))) + (warn "x: ~Z, y: ~Z" x y))) + ;;;;; (defclass food () ()) @@ -696,10 +749,6 @@ ;;;;; -(defvar div #xa65feaab511c61e33df38fdddaf03b59b6f25e1fa4de57e5cf00ae478a855dda4f3638d38bb00ac4af7d8414c3fb36e04fbdf3d3166712d43b421bfa757e85694ad27c48f396d03c8bce8da58db5b82039f35dcf857235c2f1c73b2226a361429190dcb5b6cd0edfb0ff6933900b02cecc0ce69274d8dae7c694804318d6d6b9) - -(defvar guess #x1dc19f99401de22d476c89943491fc187b80bcfa8293ec1cf69c1a81352f047e894e262d24116c82ad0be241c6c6216cab9b66d64417d43bf433db10114c0) - ;;;;;;;;;;;;;;; CL (defun install-internal-time (&optional (minimum-frequency 100)) @@ -956,23 +1005,24 @@ (return (values))))))) (defun los0-debugger (condition) - (let ((*debugger-dynamic-context* (current-dynamic-context)) - (*standard-output* *debug-io*) - (*standard-input* *debug-io*) - (*debugger-condition* condition) - (*package* (or (and (packagep *package*) *package*) - (find-package "INIT") - (find-package "USER") - (find-package "COMMON-LISP") - (error "Unable to find any package!"))) - (*repl-prompt-context* #\d) - (*repl-readline-context* (or *repl-readline-context* - (make-readline-context :history-size 16)))) - (let ((*print-safely* t)) - (invoke-toplevel-command :error)) - (loop - (with-simple-restart (abort "Abort to command level ~D." (1+ *repl-level*)) - (read-eval-print))))) + (without-interrupts + (let ((*debugger-dynamic-context* (current-dynamic-context)) + (*standard-output* *debug-io*) + (*standard-input* *debug-io*) + (*debugger-condition* condition) + (*package* (or (and (packagep *package*) *package*) + (find-package "INIT") + (find-package "USER") + (find-package "COMMON-LISP") + (error "Unable to find any package!"))) + (*repl-prompt-context* #\d) + (*repl-readline-context* (or *repl-readline-context* + (make-readline-context :history-size 16)))) + (let ((*print-safely* t)) + (invoke-toplevel-command :error)) + (loop + (with-simple-restart (abort "Abort to command level ~D." (1+ *repl-level*)) + (read-eval-print)))))) (defun ub (x) `(hello world ,x or . what)) @@ -1020,6 +1070,109 @@ (:stc)) (values eax ebx ecx edx p1 p2))) +(defun my-test-labels (x) + (labels (#+ignore (p () (print x)) + (q (y) (list x y))) + (declare (ignore q)) + (1+ x))) + +(defparameter *timer-stack* nil) +(defparameter *timer-esi* nil) +(defparameter *timer-frame* #100()) + +(defun test-clc (&optional timeout) + (test-timer timeout) + (loop + (clc::test-clc))) + +(defun test-timer (&optional timeout) + (setf (exception-handler 32) + (lambda (exception-vector exception-frame) + (declare (ignore exception-vector #+ignore 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))) +;;; (let ((ts *timer-stack*)) +;;; (setf (fill-pointer ts) 0) +;;; (loop for stack-frame = exception-frame then (stack-frame-uplink stack-frame) +;;; while (plusp stack-frame) +;;; do (multiple-value-bind (offset code-vector funobj) +;;; (stack-frame-call-site stack-frame) +;;; (vector-push funobj ts) +;;; (vector-push offset ts) +;;; (vector-push code-vector ts)))) + (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)) + (when (eq (with-inline-assembly (:returns :eax) (:movl :esi :eax)) + (stack-frame-funobj nil frame)) + (error "Double interrupt."))) + #+ignore + (dolist (range muerte::%memory-map-roots%) + (map-heap-words (lambda (x type) + (declare (ignore type)) + x) + (car range) (cdr range))) + (map-stack-words (lambda (x foo) + (declare (ignore foo)) + 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 (+ 10 (random 4000)))) + (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) + )) + (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 4000)))) + (setf (pic8259-irq-mask) #xfffe) + (pic8259-end-of-interrupt 0) + (with-inline-assembly (:returns :nothing) (:sti)) + ;; (dotimes (i 100000)) + #+ignore + (with-inline-assembly (:returns :nothing) + (:compile-two-forms (:ebx :edx) + (read-time-stamp-counter) + (read-time-stamp-counter)) + (:movl :eax (#x1000000)) + (:movl :ebx (#x1000004)) + (:movl :ecx (#x1000008)) + (:movl :edx (#x100000c)) + (:movl :ebp (#x1000010)) + (:movl :esp (#x1000014)) + (:movl :esi (#x1000018)) + (:halt) + (:cli) + (:halt) + )) + +(defun test-throwing (&optional (x #xffff)) + (test-timer x) + (loop + (catch 'foo + (funcall (lambda () + (unless (logbitp 9 (eflags)) + (break "Someone switched off interrupts!")) + (incf (memref-int muerte.x86-pc::*screen* 0 0 :unsigned-byte16 t)) + (throw 'foo nil)))))) + + (defun genesis () (let ((extended-memsize 0)) ;; Find out how much extended memory we have @@ -1030,10 +1183,10 @@ (format t "Extended memory: ~D KB~%" extended-memsize) (idt-init) - (install-los0-consing :kb-size 50) + (install-los0-consing :kb-size 500) #+ignore (install-los0-consing :kb-size (max 100 (truncate (- extended-memsize 1024 2048) 2)))) - + (setf *debugger-function* #'los0-debugger) (let ((*repl-readline-context* (make-readline-context :history-size 16)) #+ignore (*backtrace-stack-frame-barrier* (stack-frame-uplink (current-stack-frame))) @@ -1049,6 +1202,9 @@ (setf *package* (find-package "INIT")) (clos-bootstrap) + (when muerte::*multiboot-data* + (set-textmode +vga-state-90x60+)) + (cond ((not (cpu-featurep :tsc)) (warn "This CPU has no time-stamp-counter. Timer-related functions will not work.")) @@ -1065,7 +1221,7 @@ (let ((* nil) (** nil) (*** nil) (/ nil) (// nil) (/// nil) (+ nil) (++ nil) (+++ nil)) - (format t "~&Movitz image Los0 build ~D." *build-number*) + (format t "~&Movitz image Los0 build ~D [~Z]." *build-number* (cons 1 2)) (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/compiler.lisp movitz/image.lisp movitz/procfs-image.lisp movitz/special-operators-cl.lisp movitz/special-operators.lisp movitz/storage-types.lisp
by Frode Vatvedt Fjeld 15 Sep '04

15 Sep '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7579 Modified Files: compiler.lisp image.lisp procfs-image.lisp special-operators-cl.lisp special-operators.lisp storage-types.lisp Log Message: many cleanup regarding stack and register discipline. Date: Wed Sep 15 12:22:52 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.98 movitz/compiler.lisp:1.99 --- movitz/compiler.lisp:1.98 Thu Sep 2 11:16:42 2004 +++ movitz/compiler.lisp Wed Sep 15 12:22:52 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.98 2004/09/02 09:16:42 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.99 2004/09/15 10:22:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2194,15 +2194,15 @@ (setq p (list i `(:pushl ,(twop-src i))) next-pc (nthcdr 2 pc)) (explain nil "store, push => store, push reg: ~S ~S" i i2)) - ((and (instruction-is i :cmpl) - (true-and-equal (stack-frame-operand (twop-dst i)) - (load-stack-frame-p i3)) - (branch-instruction-label i2)) - (setf p (list i3 - `(:cmpl ,(twop-src i) ,(twop-dst i3)) - i2) - next-pc (nthcdr 3 pc)) - (explain nil "~S ~S ~S => ~S" i i2 i3 p)) +;;; ((and (instruction-is i :cmpl) +;;; (true-and-equal (stack-frame-operand (twop-dst i)) +;;; (load-stack-frame-p i3)) +;;; (branch-instruction-label i2)) +;;; (setf p (list i3 +;;; `(:cmpl ,(twop-src i) ,(twop-dst i3)) +;;; i2) +;;; next-pc (nthcdr 3 pc)) +;;; (explain t "~S ~S ~S => ~S" i i2 i3 p)) ((and (instruction-is i :pushl) (instruction-is i3 :popl) (store-stack-frame-p i2) Index: movitz/image.lisp diff -u movitz/image.lisp:1.66 movitz/image.lisp:1.67 --- movitz/image.lisp:1.66 Thu Sep 2 11:21:14 2004 +++ movitz/image.lisp Wed Sep 15 12:22:52 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.66 2004/09/02 09:21:14 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.67 2004/09/15 10:22:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -290,12 +290,24 @@ :initform 0) (values :binary-type #.(* 4 +movitz-multiple-values-limit+)) - (malloc-pointer-words + (get-cons-pointer :binary-type code-vector-word + :initform nil :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) - (malloc-non-pointer-words + (cons-commit + :binary-type code-vector-word + :initform nil + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (get-cons-pointer-non-pointer + :binary-type code-vector-word + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (cons-commit-non-pointer :binary-type code-vector-word :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector @@ -438,11 +450,13 @@ (segment-descriptor-7 :binary-type segment-descriptor :initform (make-segment-descriptor)) - (scratch0 ; A non-GC-root scratch register + (raw-scratch0 ; A non-GC-root scratch register :binary-type lu32 :initform 0) (non-pointers-end :binary-type :label) ; ========= NON-POINTER-END ======= - + (scratch1 + :binary-type word + :initform 0) (atomically-status :binary-type (define-bitfield atomically-status (lu32) (((:enum :byte (3 2)) @@ -456,19 +470,7 @@ :initform '(:inactive)) (atomically-esp :binary-type lu32 - :initform 0) - (get-cons-pointer - :binary-type code-vector-word - :initform nil - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function) - (cons-commit - :binary-type code-vector-word - :initform nil - :map-binary-write 'movitz-intern-code-vector - :map-binary-read-delayed 'movitz-word-code-vector - :binary-tag :primitive-function)) + :initform 0)) (:slot-align null-symbol -5)) (defun atomically-status-simple-pf (pf-name reset-status-p &rest registers) @@ -937,7 +939,7 @@ (assert (file-position stream 512) () ; leave room for bootblock. "Couldn't set file-position for ~W." (pathname stream)) (let* ((stack-vector (make-instance 'movitz-basic-vector - :num-elements #x2ffe + :num-elements #x3ffe :fill-pointer 0 :symbolic-data nil :element-type :u32)) Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.18 movitz/procfs-image.lisp:1.19 --- movitz/procfs-image.lisp:1.18 Mon Aug 30 16:59:23 2004 +++ movitz/procfs-image.lisp Wed Sep 15 12:22:52 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.18 2004/08/30 14:59:23 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.19 2004/09/15 10:22:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -196,6 +196,7 @@ (null (write-string "?") (let* ((eax (get-word (+ (* 4 (interrupt-frame-index :eax)) stack-frame))) + (ebx (get-word (+ (* 4 (interrupt-frame-index :ebx)) stack-frame))) (ecx (get-word (+ (* 4 (interrupt-frame-index :ecx)) stack-frame))) (edx (get-word (+ (* 4 (interrupt-frame-index :edx)) stack-frame))) (edi (get-word (+ (* 4 (interrupt-frame-index :edi)) stack-frame))) @@ -203,9 +204,9 @@ (esi (get-word (+ (* 4 (interrupt-frame-index :esi)) stack-frame))) (exception (get-word (+ (* 4 (interrupt-frame-index :exception-vector)) stack-frame)))) - (format t "#x~X {EAX: #x~X, ECX: #x~X, EDX: #x~X, EDI: #x~X, ESI: #x~X, EIP: #x~X, exception ~D}" + (format t "#x~X {EAX: #x~X, EBX: #x~X, ECX: #x~X, EDX: #x~X, EDI: #x~X, ESI: #x~X, EIP: #x~X, exception ~D}" stack-frame - eax ecx edx edi esi eip exception))) + eax ebx ecx edx edi esi eip exception))) (movitz-symbol (let ((name (movitz-print movitz-name))) (when print-frames Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.22 movitz/special-operators-cl.lisp:1.23 --- movitz/special-operators-cl.lisp:1.22 Thu Sep 2 11:27:32 2004 +++ movitz/special-operators-cl.lisp Wed Sep 15 12:22:52 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.22 2004/09/02 09:27:32 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.23 2004/09/15 10:22:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1182,15 +1182,10 @@ `((:pushl :ebp) ; push stack frame (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) ; install catch body-code - `((:popl :ebp) ; This value is identical to current EBP. - ,exit-point - (:leal (:esp ,(+ -8 16)) :esp)) - (if (not *compiler-produce-defensive-code*) - `((:locally (:popl (:edi (:edi-offset dynamic-env))))) - `((:xchgl :ecx (:esp)) - (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) - (:locally (:movl :ecx (:edi (:edi-offset dynamic-env)))) - (:popl :ecx))))))) + `(,exit-point + (:popl :ebp) + (:leal (:esp 8) :esp) ; Skip catch-tag and jumper + (:locally (:popl (:edi (:edi-offset dynamic-env))))))))) (define-special-operator unwind-protect (&all all &form form &env env) (destructuring-bind (protected-form &body cleanup-forms) Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.37 movitz/special-operators.lisp:1.38 --- movitz/special-operators.lisp:1.37 Thu Sep 2 11:27:38 2004 +++ movitz/special-operators.lisp Wed Sep 15 12:22:52 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.37 2004/09/02 09:27:38 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.38 2004/09/15 10:22:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1199,16 +1199,23 @@ )))) ; save dynamic-slot in EBP ;; now outside of m-v-prog1's cloak, with final dynamic-slot in ESP.. ;; ..unwind it and transfer control. - `((:load-lexical ,dynamic-slot-binding :ebp) - (:leave) - (:movl (:ebp -4) :esi) - (:movl (:esp 4) :edx) - ;; (:halt) + ;; + ;; * 12 dynamic-env uplink + ;; * 8 target jumper number + ;; * 4 target catch tag + ;; * 0 target EBP +;;; `((:load-lexical ,dynamic-slot-binding :edx) +;;; ()) + `((:load-lexical ,dynamic-slot-binding :edx) + (:locally (:movl :esi (:edi (:edi-offset scratch1)))) + (:movl :edx :esp) ; enter non-local jump stack mode. + + (:movl (:esp) :edx) ; target stack-frame EBP + (:movl (:edx -4) :esi) ; get target funobj into EDX + + (:movl (:esp 8) :edx) ; target jumper number (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0)))))))))) -;;; (:leal (:esp 8) :esp) ; skip tag and eip -;;; (:locally (:popl (:edi (:edi-offset dynamic-env)))) ; unwind dynamic env -;;; (:jmp (:esp -8)))))))) (define-special-operator muerte::with-basic-restart (&all defaults &form form &env env) (destructuring-bind ((name function interactive test format-control @@ -1284,8 +1291,9 @@ :result-mode :multiple-values :with-stack-used entry-size :form body) - `((:leal (:esp ,(+ -12 (* 4 entry-size))) :esp) + `((:leal (:esp ,(+ -12 -4 (* 4 entry-size))) :esp) ,exit-point - (:leal (:esp ,(+ -8 16)) :esp) + (:popl :ebp) + (:leal (:esp 8) :esp) (:locally (:popl (:edi (:edi-offset dynamic-env)))) ))))))) Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.39 movitz/storage-types.lisp:1.40 --- movitz/storage-types.lisp:1.39 Thu Aug 19 00:32:53 2004 +++ movitz/storage-types.lisp Wed Sep 15 12:22:52 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.39 2004/08/18 22:32:53 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.40 2004/09/15 10:22:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -58,9 +58,14 @@ :odd-fixnum 4 :cons 1 :character 2 + :tag0 0 + :tag1 1 :tag2 2 :tag3 3 ; unused :tag4 4 + :tag5 5 + :tag6 6 + :tag7 7 ;; :immediate 4 :null 5 :other 6 @@ -72,7 +77,7 @@ :bignum #x4a :ratio #x52 :complex #x5a - :defstruct #x20 + :defstruct #x2a :std-instance #x40 :run-time-context #x50 :illegal #x13 @@ -1171,12 +1176,6 @@ (make-instance 'movitz-std-instance :class (movitz-read class) :slots slots)) - -;;;(defmethod write-binary-record ((obj movitz-std-instance) stream) -;;; (+ (write-binary 'word stream (movitz-intern (movitz-std-instance-class obj))) -;;; (let ((slots (movitz-read (movitz-std-instance-slots obj)))) -;;; (assert (typep slots 'movitz-vector)) -;;; (write-binary 'word stream (movitz-intern slots))))) (defmethod print-object ((object movitz-std-instance) stream) (print-unreadable-object (object stream :identity t)

1 0

[movitz-cvs] CVS update: movitz/compiler-types.lisp
by Frode Vatvedt Fjeld 15 Sep '04

15 Sep '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7535 Modified Files: compiler-types.lisp Log Message: Removed reference to deprecated type movitz-vector. Date: Wed Sep 15 12:19:06 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.19 movitz/compiler-types.lisp:1.20 --- movitz/compiler-types.lisp:1.19 Thu Jul 29 02:12:48 2004 +++ movitz/compiler-types.lisp Wed Sep 15 12:19:06 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.19 2004/07/29 00:12:48 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.20 2004/09/15 10:19:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -251,7 +251,7 @@ (symbol (typep x 'movitz-symbol)) ((vector array) - (typep x '(or movitz-basic-vector movitz-vector))) + (typep x 'movitz-basic-vector)) (fixnum (typep x 'movitz-fixnum)) (bignum

1 0

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

06 Sep '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1518 Modified Files: loop.lisp Log Message: Don't declare the pointer variable for for-as-on-list clauses to be of type list, because that's not true if the list is improper. Date: Mon Sep 6 14:33:43 2004 Author: ffjeld Index: movitz/losp/muerte/loop.lisp diff -u movitz/losp/muerte/loop.lisp:1.5 movitz/losp/muerte/loop.lisp:1.6 --- movitz/losp/muerte/loop.lisp:1.5 Wed Feb 11 15:52:51 2004 +++ movitz/losp/muerte/loop.lisp Mon Sep 6 14:33:43 2004 @@ -1546,7 +1546,7 @@ (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) (let ((listvar var)) (cond ((and var (symbolp var)) (loop-make-iteration-variable var list data-type)) - (t (loop-make-variable (setq listvar (loop-gentemp)) list 'list) + (t (loop-make-variable (setq listvar (loop-gentemp)) list t) (loop-make-iteration-variable var nil data-type))) (multiple-value-bind (list-step step-function) (loop-list-step listvar) (declare #+(and (not LOOP-Prefer-POP) (not CLOE)) (ignore step-function))

1 0