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@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@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@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@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@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@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@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@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@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)