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)
