Commit 4d033bfb authored by Frode Vatvedt Fjeld's avatar Frode Vatvedt Fjeld

many cleanup regarding stack and register discipline.

parent add1d41b
......@@ -8,7 +8,7 @@
;;;; Created at: Wed Oct 25 12:30:49 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: compiler.lisp,v 1.97 2004/08/19 00:22:02 ffjeld Exp $
;;;; $Id: compiler.lisp,v 1.98 2004/09/02 09:16:42 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -2194,15 +2194,15 @@ falling below the label."
(setq p (list i `(:pushl ,(twop-src i)))
next-pc (nthcdr 2 pc))
(explain nil "store, push => store, push reg: ~S ~S" i i2))
((and (instruction-is i :cmpl)
(true-and-equal (stack-frame-operand (twop-dst i))
(load-stack-frame-p i3))
(branch-instruction-label i2))
(setf p (list i3
`(:cmpl ,(twop-src i) ,(twop-dst i3))
i2)
next-pc (nthcdr 3 pc))
(explain nil "~S ~S ~S => ~S" i i2 i3 p))
;;; ((and (instruction-is i :cmpl)
;;; (true-and-equal (stack-frame-operand (twop-dst i))
;;; (load-stack-frame-p i3))
;;; (branch-instruction-label i2))
;;; (setf p (list i3
;;; `(:cmpl ,(twop-src i) ,(twop-dst i3))
;;; i2)
;;; next-pc (nthcdr 3 pc))
;;; (explain t "~S ~S ~S => ~S" i i2 i3 p))
((and (instruction-is i :pushl)
(instruction-is i3 :popl)
(store-stack-frame-p i2)
......
......@@ -9,7 +9,7 @@
;;;; Created at: Sun Oct 22 00:22:43 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: image.lisp,v 1.65 2004/08/18 09:15:14 ffjeld Exp $
;;;; $Id: image.lisp,v 1.66 2004/09/02 09:21:14 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -290,12 +290,24 @@
:initform 0)
(values
:binary-type #.(* 4 +movitz-multiple-values-limit+))
(malloc-pointer-words
(get-cons-pointer
:binary-type code-vector-word
:initform nil
:map-binary-write 'movitz-intern-code-vector
:map-binary-read-delayed 'movitz-word-code-vector
:binary-tag :primitive-function)
(malloc-non-pointer-words
(cons-commit
:binary-type code-vector-word
:initform nil
:map-binary-write 'movitz-intern-code-vector
:map-binary-read-delayed 'movitz-word-code-vector
:binary-tag :primitive-function)
(get-cons-pointer-non-pointer
:binary-type code-vector-word
:map-binary-write 'movitz-intern-code-vector
:map-binary-read-delayed 'movitz-word-code-vector
:binary-tag :primitive-function)
(cons-commit-non-pointer
:binary-type code-vector-word
:map-binary-write 'movitz-intern-code-vector
:map-binary-read-delayed 'movitz-word-code-vector
......@@ -438,11 +450,13 @@
(segment-descriptor-7
:binary-type segment-descriptor
:initform (make-segment-descriptor))
(scratch0 ; A non-GC-root scratch register
(raw-scratch0 ; A non-GC-root scratch register
:binary-type lu32
:initform 0)
(non-pointers-end :binary-type :label) ; ========= NON-POINTER-END =======
(scratch1
:binary-type word
:initform 0)
(atomically-status
:binary-type (define-bitfield atomically-status (lu32)
(((:enum :byte (3 2))
......@@ -456,19 +470,7 @@
:initform '(:inactive))
(atomically-esp
:binary-type lu32
:initform 0)
(get-cons-pointer
:binary-type code-vector-word
:initform nil
:map-binary-write 'movitz-intern-code-vector
:map-binary-read-delayed 'movitz-word-code-vector
:binary-tag :primitive-function)
(cons-commit
:binary-type code-vector-word
:initform nil
:map-binary-write 'movitz-intern-code-vector
:map-binary-read-delayed 'movitz-word-code-vector
:binary-tag :primitive-function))
:initform 0))
(:slot-align null-symbol -5))
(defun atomically-status-simple-pf (pf-name reset-status-p &rest registers)
......@@ -937,7 +939,7 @@ a cons is an offset (the car) from some other code-vector (the cdr)."
(assert (file-position stream 512) () ; leave room for bootblock.
"Couldn't set file-position for ~W." (pathname stream))
(let* ((stack-vector (make-instance 'movitz-basic-vector
:num-elements #x2ffe
:num-elements #x3ffe
:fill-pointer 0
:symbolic-data nil
:element-type :u32))
......
......@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Created at: Sat Feb 21 17:48:32 2004
;;;;
;;;; $Id: los0-gc.lisp,v 1.34 2004/08/23 13:58:07 ffjeld Exp $
;;;; $Id: los0-gc.lisp,v 1.35 2004/09/02 09:33:06 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -146,7 +146,7 @@ Preserve ECX."
retry
(:locally (:cmpl 0 (:edi (:edi-offset atomically-status)))) ; Atomically?
(:je '(:sub-program ()
(:int 50))) ; This must be called inside atomically.
(:int 63))) ; This must be called inside atomically.
(:locally (:movl (:edi (:edi-offset nursery-space)) :edx))
(:movl (:edx 2) :ebx)
(:leal (:ebx :eax 4) :eax)
......@@ -205,6 +205,8 @@ Preserve EAX and EBX."
(:jae '(:sub-program ()
(:locally (:movl ,(bt:enum-value 'movitz::atomically-status :inactive)
(:edi (:edi-offset atomically-status))))
(:movl :edx (#x1000000))
(:addl :eax (#x1000000))
(:int 113) ; This interrupt can be retried.
(:jmp 'retry-cons)))
(:movl ,(dpb movitz:+movitz-fixnum-factor+
......@@ -239,9 +241,13 @@ Preserve EAX and EBX."
(:movl :ebx :eax) ; Restore count in EAX before retry
(:jmp 'retry)))
(:movl :eax (:edx 2))
(:movl ,(movitz:tag :infant-object) (:edx :ecx ,(+ 8 movitz:+other-type-offset+)))
(:movl ,(movitz:basic-vector-type-tag :any-t)
(:edx :ecx ,(+ 8 movitz:+other-type-offset+)))
(:subl 8 :ebx)
(:movl :ebx (:edx :ecx ,(+ 16 movitz:+other-type-offset+)))
(:leal (:edx :ecx 8) :eax)
(:xorl :ecx :ecx)
(:addl 8 :ecx)
init-loop ; Now init ebx number of words
(:movl :edi (:eax :ecx ,(- (movitz:tag :other))))
(:addl 4 :ecx)
......@@ -285,22 +291,22 @@ duo-space where each space is KB-SIZE kilobytes."
(setf (exception-handler 113)
(lambda (exception interrupt-frame)
(declare (ignore exception interrupt-frame))
(let ((*standard-output* *terminal-io*))
(when *gc-running*
(let ((muerte::*error-no-condition-for-debugger* t))
(warn "Recursive GC triggered.")))
(let ((*gc-running* t))
(unless *gc-quiet*
(format t "~&;; GC.. "))
(stop-and-copy))
(if *gc-break*
(break "GC break.")
(loop ; This is a nice opportunity to poll the keyboard..
(case (muerte.x86-pc.keyboard:poll-char)
((#\esc)
(break "Los0 GC keyboard poll."))
((nil)
(return))))))))
(without-interrupts
(let ((*standard-output* *terminal-io*))
(when *gc-running*
(break "Recursive GC triggered."))
(let ((*gc-running* t))
(unless *gc-quiet*
(format t "~&;; GC.. "))
(stop-and-copy))
(if *gc-break*
(break "GC break.")
(loop ; This is a nice opportunity to poll the keyboard..
(case (muerte.x86-pc.keyboard:poll-char)
((#\esc)
(break "Los0 GC keyboard poll."))
((nil)
(return)))))))))
(let* ((actual-duo-space (or duo-space
(allocate-duo-space (* kb-size #x100))))
(last-location (object-location (cons 1 2))))
......@@ -315,8 +321,8 @@ duo-space where each space is KB-SIZE kilobytes."
(install-primitive los0-box-u32-ecx muerte::box-u32-ecx)
(install-primitive los0-get-cons-pointer muerte::get-cons-pointer)
(install-primitive los0-cons-commit muerte::cons-commit)
(install-primitive los0-malloc-pointer-words muerte::malloc-pointer-words)
(install-primitive los0-malloc-non-pointer-words muerte::malloc-non-pointer-words))
#+ignore (install-primitive los0-malloc-pointer-words muerte::malloc-pointer-words)
#+ignore (install-primitive los0-malloc-non-pointer-words muerte::malloc-non-pointer-words))
(if (eq context (current-run-time-context))
(setf (%run-time-context-slot 'muerte::nursery-space)
actual-duo-space)
......@@ -384,6 +390,10 @@ duo-space where each space is KB-SIZE kilobytes."
(check-type space0 vector-u32)
(check-type space1 vector-u32)
(assert (eq space0 (space-other space1)))
(assert (= 2 (space-fresh-pointer space1)))
(setf (%run-time-context-slot 'nursery-space) space1)
(values space1 space0)
#+ignore
(multiple-value-bind (newspace oldspace)
(if (< (space-fresh-pointer space0) ; Chose the emptiest space as newspace.
(space-fresh-pointer space1))
......@@ -403,23 +413,22 @@ duo-space where each space is KB-SIZE kilobytes."
nil)
((not (object-in-space-p oldspace x))
x)
(t
(or (and (eq (object-tag x)
(ldb (byte 3 0)
(memref (object-location x) 0 0 :unsigned-byte8)))
(let ((forwarded-x (memref (object-location x) 0 0 :lisp)))
(and (object-in-space-p newspace forwarded-x)
forwarded-x)))
(let ((forward-x (shallow-copy x)))
(when (and (typep x 'muerte::pointer)
*gc-consitency-check*)
(let ((a *x*))
(vector-push (%object-lispval x) a)
(vector-push (memref (object-location x) 0 0 :unsigned-byte32) a)
(assert (vector-push (%object-lispval forward-x) a))))
(setf (memref (object-location x) 0 0 :lisp) forward-x)
forward-x))))))))
(setf *gc-stack* (muerte::copy-control-stack))
(t (or (and (eq (object-tag x)
(ldb (byte 3 0)
(memref (object-location x) 0 0 :unsigned-byte8)))
(let ((forwarded-x (memref (object-location x) 0 0 :lisp)))
(and (object-in-space-p newspace forwarded-x)
forwarded-x)))
(let ((forward-x (shallow-copy x)))
(when (and (typep x 'muerte::pointer)
*gc-consitency-check*)
(let ((a *x*))
(vector-push (%object-lispval x) a)
(vector-push (memref (object-location x) 0 0 :unsigned-byte32) a)
(assert (vector-push (%object-lispval forward-x) a))))
(setf (memref (object-location x) 0 0 :lisp) forward-x)
forward-x))))))))
(setf *gc-stack* (muerte::copy-current-control-stack))
;; Scavenge roots
(dolist (range muerte::%memory-map-roots%)
(map-heap-words evacuator (car range) (cdr range)))
......@@ -470,5 +479,36 @@ oldspace: ~Z, newspace: ~Z, i: ~D"
~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%"
old-size new-size (- old-size new-size))))
(initialize-space oldspace)
#+ignore (fill oldspace #x13 :start 2)))
(fill oldspace #x13 :start 2)))
(values))
(defun find-object-by-location (location &key (continuep t) (breakp nil))
"Scan the heap for a (pointer) object that matches location.
This is a debugging tool."
(let ((results nil))
(flet ((searcher (x ignore)
(declare (ignore ignore))
(when (and (typep x '(or muerte::tag1 muerte::tag6 muerte::tag7))
(not (eq x (%run-time-context-slot 'muerte::nursery-space)))
(location-in-object-p x location)
(not (member x results)))
(push x results)
(funcall (if breakp #'break #'warn)
"Found pointer ~Z of type ~S at location ~S."
x (type-of x) (object-location x)))
x))
(handler-bind
((serious-condition (lambda (c)
(when (and continuep
(find-restart 'muerte::continue-map-heap-words))
(warn "Automatic continue from scanning error: ~A" c)
(invoke-restart 'muerte::continue-map-heap-words)))))
(dolist (range muerte::%memory-map-roots%)
(map-heap-words #'searcher (car range) (cdr range)))
(let ((nursery (%run-time-context-slot 'muerte::nursery-space)))
(map-heap-words #'searcher
(+ 4 (object-location nursery))
(+ 4 (object-location nursery) (space-fresh-pointer nursery))))
(map-stack-words #'searcher nil (current-stack-frame))))
results))
This diff is collapsed.
......@@ -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.37 2004/08/14 17:53:25 ffjeld Exp $
;;;; $Id: basic-macros.lisp,v 1.38 2004/08/18 22:35:45 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -1066,7 +1066,52 @@ busy-waiting loop on P4."
(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)
......@@ -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.5 2004/07/20 08:53:56 ffjeld Exp $
;;;; $Id: bignums.lisp,v 1.6 2004/08/18 22:36:37 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -64,6 +64,8 @@ that the msb isn't zero. DO NOT APPLY TO NON-BIGNUM VALUES!"
(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 @@ that the msb isn't zero. DO NOT APPLY TO NON-BIGNUM VALUES!"
(: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 @@ that the msb isn't zero. DO NOT APPLY TO NON-BIGNUM VALUES!"
(: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)))
)))
......
......@@ -9,7 +9,7 @@
;;;; Created at: Mon Jan 22 13:10:59 2001
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: defstruct.lisp,v 1.11 2004/07/24 01:30:44 ffjeld Exp $
;;;; $Id: defstruct.lisp,v 1.12 2004/07/27 09:19:09 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.
......
......@@ -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.17 2004/07/20 12:58:34 ffjeld Exp $
;;;; $Id: functions.lisp,v 1.18 2004/08/16 15:28:07 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
......@@ -359,7 +359,6 @@ as that vector."
(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 @@ as that vector."
(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 @@ so that we can be reasonably sure of dst's size."
(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)
......
This diff is collapsed.
......@@ -9,7 +9,7 @@
;;;; Created at: Wed Nov 8 18:44:57 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: integers.lisp,v 1.92 2004/08/16 15:26:36 ffjeld Exp $
;;;; $Id: integers.lisp,v 1.93 2004/08/18 09:50:33 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)
......
......@@ -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.21 2004/08/18 22:37:56 ffjeld Exp $
;;;; $Id: interrupt.lisp,v 1.22 2004/09/02 09:45:26 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)