From ffjeld at common-lisp.net Mon Jan 3 11:52:37 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 3 Jan 2005 12:52:37 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/compiler-types.lisp Message-ID: <20050103115237.6151C884A5@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv9028 Modified Files: compiler-types.lisp Log Message: Fixed an off-by-one thingy in numscopes (which represent integer types). Date: Mon Jan 3 12:52:35 2005 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.21 movitz/compiler-types.lisp:1.22 --- movitz/compiler-types.lisp:1.21 Wed Nov 10 16:31:41 2004 +++ movitz/compiler-types.lisp Mon Jan 3 12:52:33 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.21 2004/11/10 15:31:41 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.22 2005/01/03 11:52:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -168,9 +168,9 @@ (numscope-add-range new-numscope (car sub-range) (- min epsilon) epsilon)) (setf new-numscope (numscope-add-range new-numscope (+ max epsilon) (cdr sub-range) epsilon))) - ((and a (not c)) ; (warn "left prune ~D with [~D-~D]" sub-range min max) + ((and a (not c)) ; (warn "left prune ~D with [~D - ~D]" new-numscope min max) (setf new-numscope - (numscope-add-range new-numscope max (cdr sub-range) epsilon))) + (numscope-add-range new-numscope (+ max epsilon) (cdr sub-range) epsilon))) ((and (not d) b) ; (warn "right prune ~D with [~D-~D]" sub-range min max) (setf new-numscope (numscope-add-range new-numscope (car sub-range) min epsilon))) From ffjeld at common-lisp.net Mon Jan 3 11:53:52 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 3 Jan 2005 12:53:52 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: <20050103115352.20134884A5@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9055 Modified Files: scavenge.lisp Log Message: Some tweaking of map-stack-vector. Date: Mon Jan 3 12:53:49 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.37 movitz/losp/muerte/scavenge.lisp:1.38 --- movitz/losp/muerte/scavenge.lisp:1.37 Fri Dec 10 13:47:37 2004 +++ movitz/losp/muerte/scavenge.lisp Mon Jan 3 12:53:47 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.37 2004/12/10 12:47:37 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.38 2005/01/03 11:53:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -248,9 +248,9 @@ (dit-frame-ref stack dit-frame :eip :unsigned-byte32) (memref interrupted-esp 0 :type :unsigned-byte32) (funobj-name casf-funobj)) - (map-region function (+ interrupted-esp 1) frame) (when (eq 0 (stack-frame-ref stack frame -1)) (break "X1 call in DIT-frame.")) + (map-region function (+ interrupted-esp 1) frame) (setf next-frame frame next-nether-frame (+ interrupted-esp 1 -2))) ((let ((x1-tag (ldb (byte 3 0) @@ -280,6 +280,8 @@ () "Stack discipline situation ii. invariant broken. CASF=#x~X, ESP=~S, EBP=~S" casf-frame interrupted-esp interrupted-ebp) + (when (eq 0 (stack-frame-ref stack frame -1)) + (break "X1 ii call in DIT-frame.")) (map-region function (+ interrupted-esp 2) frame) (setf next-frame frame next-nether-frame (+ interrupted-esp 2 -2))) @@ -288,6 +290,8 @@ (memref interrupted-esp 0 :type :location)) () "Stack discipline situation iii. invariant broken. CASF=#x~X" casf-frame) + (when (eq 0 (stack-frame-ref stack frame -1)) + (break "X1 iii call in DIT-frame.")) (map-region function (+ interrupted-esp 1) frame) (setf next-frame frame next-nether-frame (+ interrupted-esp 1 -2)))))) From ffjeld at common-lisp.net Mon Jan 3 11:55:07 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 3 Jan 2005 12:55:07 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050103115507.40C2C884A5@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv9077 Modified Files: compiler.lisp Log Message: Started support for stack-allocating functions (of dynamic extent). Primary purpose is to evaluate e.g. handler-case without having to cons up a function for each handler. Date: Mon Jan 3 12:55:05 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.123 movitz/compiler.lisp:1.124 --- movitz/compiler.lisp:1.123 Tue Dec 21 15:23:49 2004 +++ movitz/compiler.lisp Mon Jan 3 12:55:04 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001,2000, 2002-2004, +;;;; Copyright (C) 2001,2000, 2002-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Description: A simple lisp compiler. @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.123 2004/12/21 14:23:49 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.124 2005/01/03 11:55:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -96,7 +96,7 @@ (make-hash-table :test #'eq)) -(defconstant +enter-stack-frame-code+ +(defparameter +enter-stack-frame-code+ '((:pushl :ebp) (:movl :esp :ebp) (:pushl :esi))) @@ -189,6 +189,13 @@ (funobj-env :initarg :funobj-env :accessor funobj-env) + (extent + :initarg :extent + :initform :unused + :accessor movitz-funobj-extent) + (allocation + :initform nil + :accessor movitz-allocation) (entry-protocol :initform :default :initarg :entry-protocol @@ -643,18 +650,30 @@ (:call-lexical (process-binding funobj (second instruction) '(:call))) (:load-lambda - (let ((lambda-binding (second instruction))) + (destructuring-bind (lambda-binding lambda-result-mode capture-env) + (cdr instruction) + (declare (ignore lambda-result-mode)) (assert (eq funobj (binding-funobj lambda-binding)) () "A non-local lambda doesn't make sense. There must be a bug.") - (resolve-sub-funobj funobj (function-binding-funobj lambda-binding)) - (process-binding funobj lambda-binding '(:read)) - ;; This funobj is effectively using every binding that the lambda - ;; is borrowing.. - (map nil (lambda (borrowed-binding) - (process-binding funobj - (borrowed-binding-target borrowed-binding) - '(:read))) - (borrowed-bindings (function-binding-funobj lambda-binding))))) + (let ((lambda-funobj (function-binding-funobj lambda-binding))) + (let ((dynamic-extent (dynamic-extent-allocation capture-env))) + (when dynamic-extent + (let ((dynamic-scope (allocation-env-scope dynamic-extent))) + ;; (warn "Adding ~S to ~S/~S" lambda-funobj dynamic-extent dynamic-scope) + (setf (movitz-funobj-extent lambda-funobj) :dynamic-extent + (movitz-allocation lambda-funobj) dynamic-scope) + (push lambda-funobj + (dynamic-extent-scope-members (allocation-env-scope dynamic-extent))) + (process-binding funobj (base-binding dynamic-scope) '(:read))))) + (resolve-sub-funobj funobj lambda-funobj) + (process-binding funobj lambda-binding '(:read)) + ;; This funobj is effectively using every binding that the lambda + ;; is borrowing.. + (map nil (lambda (borrowed-binding) + (process-binding funobj + (borrowed-binding-target borrowed-binding) + '(:read))) + (borrowed-bindings (function-binding-funobj lambda-binding)))))) (:local-function-init (let ((function-binding (second instruction))) (assert (eq funobj (binding-funobj function-binding)) () @@ -696,6 +715,7 @@ do (pushnew borrowed-binding (getf (binding-lending (borrowed-binding-target borrowed-binding)) :lended-to))) + ;; (warn "old extent: ~S" (movitz-funobj-extent sub-funobj)) (cond ((or (null usage) (null (borrowed-bindings sub-funobj))) @@ -708,12 +728,16 @@ (change-class function-binding 'closure-binding) (setf (movitz-funobj-extent sub-funobj) :lexical-extent)) + ((eq :dynamic-extent (movitz-funobj-extent sub-funobj)) + (change-class function-binding 'closure-binding)) (t (change-class function-binding 'closure-binding) (setf (movitz-funobj-extent sub-funobj) :indefinite-extent))) ; XXX - #+ignore (warn "extent: ~S => ~S" - sub-funobj - (movitz-funobj-extent sub-funobj))))) + #+ignore + (warn "extent usage ~S: ~S => ~S" + usage + sub-funobj + (movitz-funobj-extent sub-funobj))))) (loop for function-binding in function-binding-usage by #'cddr do (finalize-funobj (function-binding-funobj function-binding))) (finalize-funobj toplevel-funobj)) @@ -1003,8 +1027,18 @@ (defun check-locate-concistency (code-vector) (loop for x from 0 below (length code-vector) by 8 do (when (and (= (tag :basic-vector) (aref code-vector x)) - (= (enum-value 'movitz-vector-element-type :code) (aref code-vector (1+ x)))) - (break "Code-vector can break %find-code-vector at offset ~D." x))) + (= (enum-value 'movitz-vector-element-type :code) (aref code-vector (1+ x))) + (or (<= #x4000 (length code-vector)) + (and (= (ldb (byte 8 0) (length code-vector)) + (aref code-vector (+ x 2))) + (= (ldb (byte 8 8) (length code-vector)) + (aref code-vector (+ x 3)))))) + (break "Code-vector (length #x~X) can break %find-code-vector at ~D: #x~2,'0X~2,'0X ~2,'0X~2,'0X." + (length code-vector) x + (aref code-vector (+ x 0)) + (aref code-vector (+ x 1)) + (aref code-vector (+ x 2)) + (aref code-vector (+ x 3))))) (values)) #+ignore @@ -1585,10 +1619,10 @@ (0 nil) (1 (cadr c)) (2 (twop-dst c))))) - (non-destructuve-p (c) + (non-destructive-p (c) (let ((c (ignore-instruction-prefixes c))) (and (consp c) - (member (car c) '(:testl :testb :pushl :cmpl :cmpb :frame-map :std))))) + (member (car c) '(:testl :testb :cmpl :cmpb :frame-map :std))))) (simple-instruction-p (c) (let ((c (ignore-instruction-prefixes c))) (and (listp c) @@ -1627,7 +1661,7 @@ (or (global-funcall-p i) (instruction-is i :frame-map) (branch-instruction-label i) - (non-destructuve-p i) + (non-destructive-p i) (and (simple-instruction-p i) (not (eql stack-location (stack-frame-operand (idst i))))))))) (preserves-register-p (i register) @@ -1637,10 +1671,12 @@ (not (eq register (idst i)))) (instruction-is i :frame-map) (branch-instruction-label i) - (non-destructuve-p i) + (non-destructive-p i) (and (member register '(:edx)) (member (global-funcall-p i) - '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx))))))) + '(fast-car fast-cdr fast-car-ebx fast-cdr-ebx))) + (and (not (eq register :esp)) + (instruction-is i :pushl)))))) (operand-register-indirect-p (operand register) (and (consp operand) (tree-search operand register))) @@ -1811,7 +1847,7 @@ (twop-src ii)) (pushnew (store-stack-frame-p ii) modifieds)) - ((non-destructuve-p ii)) + ((non-destructive-p ii)) ((branch-instruction-label ii)) ((simple-instruction-p ii) (let ((op (idst ii))) @@ -2813,14 +2849,16 @@ (cdr (first init-pc)) (declare (ignore protect-registers protect-carry init-with-type)) (assert (eq binding init-binding)) - (let* ((load-instruction - (find-if (lambda (i) - (and (not (instruction-is i :init-lexvar)) - (member binding (find-read-bindings i) - :test #'binding-eql))) - (cdr init-pc))) - (binding-destination (third load-instruction)) - (distance (position load-instruction (cdr init-pc)))) + (multiple-value-bind (load-instruction binding-destination distance) + (loop for i in (cdr init-pc) as distance upfrom 0 + do (when (not (instruction-is i :init-lexvar)) + (multiple-value-bind (read-bindings read-destinations) + (find-read-bindings i) + (let ((pos (position binding read-bindings :test #'binding-eql))) + (when pos + (return (values i (nth pos read-destinations) distance))))))) + (declare (ignore load-instruction)) + ;; (warn "load: ~S, dist: ~S, dest: ~S" load-instruction distance binding-destination) (multiple-value-bind (free-registers more-later-p) (and distance (compute-free-registers (cdr init-pc) distance funobj frame-map)) (let ((free-registers-no-ecx (remove :ecx free-registers))) @@ -2912,6 +2950,15 @@ ((:local-function-init :load-lambda) (let ((function-binding (second instruction))) (take-note-of-binding function-binding) + (let ((sub-funobj (function-binding-funobj function-binding))) + #+ignore + (warn "fun-ext: ~S ~S ~S" + sub-funobj + (movitz-funobj-extent sub-funobj) + (movitz-allocation sub-funobj)) + (when (typep (movitz-allocation sub-funobj) + 'with-dynamic-extent-scope-env) + (take-note-of-binding (base-binding (movitz-allocation sub-funobj))))) (let ((closure-funobj (function-binding-funobj function-binding))) (dolist (borrowing-binding (borrowed-bindings closure-funobj)) (lend-lexical borrowing-binding nil))))) @@ -3189,6 +3236,11 @@ (:load-lambda (or (when load (binding-eql binding (second instruction))) + (let ((allocation (movitz-allocation + (function-binding-funobj (second instruction))))) + (when (and load + (typep allocation 'with-dynamic-extent-scope-env)) + (binding-eql binding (base-binding allocation)))) (search-funobj (function-binding-funobj (second instruction)) binding load store call))) (:call-lexical @@ -3321,9 +3373,6 @@ code) env stack-frame-position frame-map)) -(defconstant +dynamic-frame-marker+ #xd193) -(defconstant +dynamic-catch-marker+ #xd293) - (defun single-value-register (mode) (ecase mode ((:eax :single-value :multiple-values :function) :eax) @@ -3670,10 +3719,19 @@ (assert (eq funobj-register :edx)) (when (getf (binding-lending lended-binding) :dynamic-extent-p) (assert dynamic-extent-p)) - ;; (warn "lending: ~W" lended-binding) + #+ignore + (warn "lending: ~W: ~S" + lended-binding + (mapcar #'movitz-funobj-extent + (mapcar #'binding-funobj + (getf (binding-lending lended-binding) :lended-to)))) (append (make-load-lexical lended-binding :eax funobj t frame-map) (unless (or (typep lended-binding 'borrowed-binding) - (getf (binding-lending lended-binding) :dynamic-extent-p)) + (getf (binding-lending lended-binding) :dynamic-extent-p) + (every (lambda (borrower) + (member (movitz-funobj-extent (binding-funobj borrower)) + '(:lexical-extent :dynamic-extent))) + (getf (binding-lending lended-binding) :lended-to))) (append `((:pushl :edx) (:globally (:call (:edi (:edi-offset ensure-heap-cons-variable)))) (:popl :edx)) @@ -3754,8 +3812,23 @@ nil) ((typep function-binding 'funobj-binding) nil) - (t (when (null (borrowed-bindings sub-funobj)) - (warn "null lending for ~S" sub-funobj)) + #+ignore + ((member (movitz-funobj-extent sub-funobj) + '(:dynamic-extent :lexical-extent)) + (check-type function-binding closure-binding) + (when (plusp (movitz-funobj-num-jumpers sub-funobj)) + (break "Don't know yet how to stack a funobj with jumpers.")) + (let ((words (+ (movitz-funobj-num-constants sub-funobj) + (/ (sizeof 'movitz-funobj) 4)))) + (break "words for ~S: ~S" words sub-funobj) + (append `((:movl :esp :eax) + (:testl 4 :eax) + (:jz 'no-alignment-needed) + (:pushl :edi) + no-alignment-needed) + (make-load-constant sub-funobj :eax funobj frame-map) + ))) + (t (assert (not (null (borrowed-bindings sub-funobj)))) (append (make-load-constant sub-funobj :eax funobj frame-map) `((:movl (:edi ,(global-constant-offset 'copy-funobj)) :esi) (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%1op))) @@ -3765,8 +3838,9 @@ append (make-lend-lexical bb :edx nil)))))) funobj frame-map))) (:load-lambda - (destructuring-bind (function-binding register) + (destructuring-bind (function-binding register capture-env) (operands instruction) + (declare (ignore capture-env)) ;; (warn "load-lambda not completed for ~S" function-binding) (finalize-code (let* ((sub-funobj (function-binding-funobj function-binding)) @@ -3777,6 +3851,17 @@ ((null lend-code) ;; (warn "null lambda lending") (append (make-load-constant sub-funobj register funobj frame-map))) + ((typep (movitz-allocation sub-funobj) + 'with-dynamic-extent-scope-env) + (let ((dynamic-scope (movitz-allocation sub-funobj))) + (append (make-load-lexical (base-binding dynamic-scope) :edx + funobj nil frame-map) + `((:leal (:edx ,(tag :other) + ,(dynamic-extent-object-offset dynamic-scope + sub-funobj)) + :edx)) + lend-code + `((:movl :edx ,register))))) (t (append (make-load-constant sub-funobj :eax funobj frame-map) `((:movl (:edi ,(global-constant-offset 'copy-funobj)) :esi) (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%1op))) @@ -3921,7 +4006,7 @@ `((,op ,(new-make-compiled-constant-reference movitz-obj funobj) ,result-mode)))))))) -(defconstant +movitz-lambda-list-keywords+ +(defparameter +movitz-lambda-list-keywords+ '(muerte.cl:&OPTIONAL muerte.cl:&REST muerte.cl:&KEY @@ -5825,16 +5910,18 @@ (assert (null unwind-protects) () "Lexical unwind-protect not implemented, to-env: ~S. (this is not supposed to happen)" to-env) + ;; (warn "dist: ~S, slots: ~S" stack-distance num-dynamic-slots) (cond ((and (eq t stack-distance) - (zerop num-dynamic-slots)) + (eql 0 num-dynamic-slots)) (compiler-values () :returns :non-local-exit :code (append return-code (unless (eq :function (exit-result-mode to-env)) - `((:load-lexical ,(save-esp-variable to-env) :esp))) + `((:load-lexical ,(movitz-binding (save-esp-variable to-env) to-env nil) :esp))) `((:jmp ',to-label))))) - ((eq t stack-distance) + ((or (eq t stack-distance) + (eq t num-dynamic-slots)) (compiler-values () :returns :non-local-exit :code (append return-code @@ -5850,7 +5937,7 @@ (:locally (:call (:edi (:edi-offset dynamic-unwind-next)))) (:locally (:movl :eax (:edi (:edi-offset dynamic-env)))) (:jc '(:sub-program () (:int 63)))))) - `((:load-lexical ,(save-esp-variable to-env) :esp) + `((:load-lexical ,(movitz-binding (save-esp-variable to-env) to-env nil) :esp) (:jmp ',to-label))))) ((zerop num-dynamic-slots) (compiler-values () @@ -5923,6 +6010,8 @@ (+ x y) t)) (find-stack-delta (env stack-distance num-dynamic-slots unwind-protects) + #+ignore (warn "find-stack-delta: ~S dist ~S, slots ~S" env + (stack-used env) (num-dynamic-slots env)) (cond ((eq outer-env env) ;; Each dynamic-slot is 4 stack-distances, so let's check that.. @@ -5935,7 +6024,7 @@ (values nil 0 nil)) (t (find-stack-delta (movitz-environment-uplink env) (stack-distance-add stack-distance (stack-used env)) - (+ num-dynamic-slots (num-dynamic-slots env)) + (stack-distance-add num-dynamic-slots (num-dynamic-slots env)) (if (typep env 'unwind-protect-env) (cons env unwind-protects) unwind-protects)))))) @@ -6000,9 +6089,7 @@ (let* ((operator (car extended-instruction)) (finder (gethash operator *extended-code-find-read-binding*))) (when finder - (let ((result (funcall finder extended-instruction))) - (check-type result list "a list of read bindings") - result))))) + (funcall finder extended-instruction))))) (defmacro define-find-write-binding-and-type (name lambda-list &body body) (let ((defun-name (intern @@ -6098,9 +6185,9 @@ (list source))))) (define-find-read-bindings :load-lexical (source destination &key &allow-other-keys) - (declare (ignore destination)) (check-type source binding) - (list source)) + (values (list source) + (list destination))) (define-extended-code-expander :load-lexical (instruction funobj frame-map) (destructuring-bind (source destination &key shared-reference-p tmp-register protect-registers) @@ -6781,3 +6868,67 @@ (:call (:esi ,(bt:slot-offset 'movitz-funobj 'code-vector%2op))) ,eql-done)))) (t (error "unknown eql: ~S" instruction)))))))) + +(define-find-read-bindings :load-lambda (lambda-binding result-mode capture-env) + (declare (ignore result-mode capture-env)) + (let ((allocation (movitz-allocation (function-binding-funobj lambda-binding)))) + (when (typep allocation 'with-dynamic-extent-scope-env) + (values (list (base-binding allocation)) + (list :edx))))) + +(define-find-write-binding-and-type :enter-dynamic-scope (instruction) + (destructuring-bind (scope-env) + (cdr instruction) + (if (null (dynamic-extent-scope-members scope-env)) + (values nil) + (values (base-binding scope-env) 'fixnum)))) + +(define-extended-code-expander :enter-dynamic-scope (instruction funobj frame-map) + (declare (ignore funobj frame-map)) + (destructuring-bind (scope-env) + (cdr instruction) + (if (null (dynamic-extent-scope-members scope-env)) + nil + (append `((:pushl :edi) + (:movl :esp :eax) + (:andl 4 :eax) + (:addl :eax :esp)) + (loop for object in (reverse (dynamic-extent-scope-members scope-env)) + appending + (etypecase object + (movitz-funobj + (append (unless (zerop (mod (sizeof object) 8)) + `((:pushl :edi))) + `((:load-constant ,object :eax)) + (loop for i from (1- (movitz-funobj-num-constants object)) + downto (movitz-funobj-num-jumpers object) + collect `(:pushl (:eax ,(slot-offset 'movitz-funobj 'constant0) + ,(* 4 i)))) + (loop repeat (movitz-funobj-num-jumpers object) + do (error "Can't handle jumpers.") + collect `(:pushl 0)) + `((:pushl (:eax ,(slot-offset 'movitz-funobj 'num-jumpers))) + (:pushl (:eax ,(slot-offset 'movitz-funobj 'name))) + (:pushl (:eax ,(slot-offset 'movitz-funobj 'lambda-list))) + +;;; (:pushl 0) ; %3op +;;; (:pushl 0) ; %2op +;;; (:pushl 0) ; %1op +;;; (:pushl 0) ; (default) + (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector%3op))) + (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector%2op))) + (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector%1op))) + (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector))) + + (:pushl (:eax ,(slot-offset 'movitz-funobj 'type)))))))))))) + +;;;(define-extended-code-expander :exit-dynamic-scope (instruction funobj frame-map) +;;; nil) + +(define-find-read-bindings :lexical-control-transfer (return-code return-mode from-env to-env + &optional to-label) + (declare (ignore return-code return-mode to-label)) + (let ((distance (stack-delta from-env to-env))) + (when (eq t distance) + (values (list (movitz-binding (save-esp-variable to-env) to-env nil)) + (list :esp))))) From ffjeld at common-lisp.net Mon Jan 3 11:55:21 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 3 Jan 2005 12:55:21 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/environment.lisp Message-ID: <20050103115521.74C0E884FE@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv9096 Modified Files: environment.lisp Log Message: Started support for stack-allocating functions (of dynamic extent). Primary purpose is to evaluate e.g. handler-case without having to cons up a function for each handler. Date: Mon Jan 3 12:55:13 2005 Author: ffjeld Index: movitz/environment.lisp diff -u movitz/environment.lisp:1.10 movitz/environment.lisp:1.11 --- movitz/environment.lisp:1.10 Thu Dec 9 15:03:28 2004 +++ movitz/environment.lisp Mon Jan 3 12:55:13 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2000-2004 +;;;; Copyright (C) 2000-2005 ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: environment.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 3 11:40:15 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: environment.lisp,v 1.10 2004/12/09 14:03:28 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.11 2005/01/03 11:55:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -101,11 +101,16 @@ :initarg :num-specials :accessor num-specials))) +(defclass progv-env (with-things-on-stack-env) + ((stack-used + :initform t) + (num-specials + :initform t))) + (defun make-stack-use-env (stack-used) (make-instance 'with-things-on-stack-env :stack-used stack-used)) - (defclass let-env (with-things-on-stack-env) ((bindings :initform nil @@ -121,6 +126,45 @@ :initform nil :accessor special-variable-shadows))) +(defclass with-dynamic-extent-scope-env (let-env) + ((save-esp-binding + :initarg :save-esp-binding + :accessor save-esp-binding) + (base-binding + :initarg :base-binding + :accessor base-binding) + (scope-tag + :initarg :scope-tag + :reader dynamic-extent-scope-tag) + (stack-used + :initform t) + (members + :initform nil + :accessor dynamic-extent-scope-members))) + +(defun dynamic-extent-allocation (env) + (loop for e = env then (movitz-environment-uplink e) + while e + do (when (typep e 'with-dynamic-extent-allocation-env) + (return e)))) + +(defun dynamic-extent-object-offset (scope-env object) + (loop with offset = 0 + for x in (dynamic-extent-scope-members scope-env) + do (if (eq x object) + (return (* 8 offset)) + (incf offset (truncate (+ (sizeof x) 4) 8))))) + +(defmethod print-object ((env with-dynamic-extent-scope-env) stream) + (print-unreadable-object (env stream :type t) + (princ (dynamic-extent-scope-tag env) stream)) + env) + +(defclass with-dynamic-extent-allocation-env (movitz-environment) + ((scope + :initarg :scope + :reader allocation-env-scope))) + (defclass funobj-env (let-env) () (:documentation "A funobj-env represents the (possibly null) @@ -189,7 +233,7 @@ t) (t (sub-env-p (movitz-environment-uplink sub-env) env)))) -(defmethod num-dynamic-slots ((x let-env)) +(defmethod num-dynamic-slots ((x with-things-on-stack-env)) (num-specials x)) (defmethod print-object ((object let-env) stream) From ffjeld at common-lisp.net Mon Jan 3 11:55:29 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 3 Jan 2005 12:55:29 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp Message-ID: <20050103115529.F1EEB884FE@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv9113 Modified Files: special-operators-cl.lisp Log Message: Started support for stack-allocating functions (of dynamic extent). Primary purpose is to evaluate e.g. handler-case without having to cons up a function for each handler. Date: Mon Jan 3 12:55:28 2005 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.39 movitz/special-operators-cl.lisp:1.40 --- movitz/special-operators-cl.lisp:1.39 Thu Dec 9 23:45:36 2004 +++ movitz/special-operators-cl.lisp Mon Jan 3 12:55:27 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2000-2004, +;;;; Copyright (C) 2000-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: special-operators-cl.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.39 2004/12/09 22:45:36 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.40 2005/01/03 11:55:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -862,24 +862,29 @@ (let ((block-env (movitz-env-get block-name :block-name nil env))) (assert block-env (block-name) "Block-name not found for return-from: ~S." block-name) - (cond - ((and (eq funobj (movitz-environment-funobj block-env)) - (null (nth-value 2 (stack-delta env block-env)))) - (compiler-values-bind (&code return-code &returns return-mode) - (compiler-call #'compile-form - :forward all - :form result-form - :result-mode (exit-result-mode block-env)) - (compiler-values () - :returns :non-local-exit - :code (append return-code - `((:lexical-control-transfer nil ,return-mode ,env ,block-env)))))) - ((not (and (eq funobj (movitz-environment-funobj block-env)) - (null (nth-value 2 (stack-delta env block-env))))) - (compiler-call #'compile-form-unprotected - :forward all - :form `(muerte::exact-throw ,(save-esp-variable block-env) - ,result-form))))))) + (multiple-value-bind (stack-distance num-dynamic-slots unwind-protects) + (stack-delta env block-env) + (declare (ignore stack-distance)) + (cond + ((and (eq funobj (movitz-environment-funobj block-env)) + (not (eq t num-dynamic-slots)) + (null unwind-protects)) + (compiler-values-bind (&code return-code &returns return-mode) + (compiler-call #'compile-form + :forward all + :form result-form + :result-mode (exit-result-mode block-env)) + (compiler-values () + :returns :non-local-exit + :code (append return-code + `((:lexical-control-transfer nil ,return-mode ,env ,block-env)))))) + ((not (and (eq funobj (movitz-environment-funobj block-env)) + (not (eq t num-dynamic-slots)) + (null unwind-protects))) + (compiler-call #'compile-form-unprotected + :forward all + :form `(muerte::exact-throw ,(save-esp-variable block-env) + ,result-form)))))))) (define-special-operator require (&form form) (let ((*require-dependency-chain* @@ -1023,31 +1028,7 @@ :functional-p t :returns lambda-result-mode :modifies nil - :code `((:load-lambda ,lambda-binding ,lambda-result-mode))))) - #+old-compiler - (cond - ((movitz-funobj-borrowed-bindings closure-funobj) - (compiler-values () - :type 'function - :functional-p nil - :returns :edx - :modifies (movitz-funobj-borrowed-bindings closure-funobj) - :code (append - (compiler-call #'compile-form - :env env - :funobj funobj - :result-mode :edx - :form `(muerte::copy-funobj ,closure-funobj)) - (loop for borrowing-binding in (movitz-funobj-borrowed-bindings closure-funobj) - as lended-binding = (borrowed-binding-target borrowing-binding) - append - `((:lend-lexical ,lended-binding ,borrowing-binding :edx)))))) - ((null (movitz-funobj-borrowed-bindings closure-funobj)) - (compiler-call #'compile-self-evaluating - :env env - :funobj funobj - :result-mode result-mode - :form closure-funobj)))))))))) + :code `((:load-lambda ,lambda-binding ,lambda-result-mode ,env)))))))))))) (define-special-operator flet (&all forward &form form &env env &funobj funobj) (destructuring-bind (flet-specs &body declarations-and-body) @@ -1063,18 +1044,28 @@ (multiple-value-bind (flet-body flet-declarations flet-docstring) (parse-docstring-declarations-and-body flet-dd-body) (declare (ignore flet-docstring)) - (make-instance 'function-binding - :name flet-name - :parent-funobj funobj - :funobj (make-compiled-funobj-pass1 (list 'muerte.cl::flet - (movitz-funobj-name funobj) - flet-name) - flet-lambda-list - flet-declarations - (list* 'muerte.cl:block - (compute-function-block-name flet-name) - flet-body) - env nil))) + (let ((flet-funobj + (make-compiled-funobj-pass1 (list 'muerte.cl::flet + (movitz-funobj-name funobj) + flet-name) + flet-lambda-list + flet-declarations + (list* 'muerte.cl:block + (compute-function-block-name flet-name) + flet-body) + env nil))) + (when (find-if (lambda (declaration) + (and (eq 'muerte.cl:dynamic-extent (car declaration)) + (member `(muerte.cl:function ,flet-name) + (cdr declaration) + :test #'equal))) + declarations) + (setf (movitz-funobj-extent flet-funobj) :dynamic-extent) + (warn "dynamic-extent flet: ~S" flet-name)) + (make-instance 'function-binding + :name flet-name + :parent-funobj funobj + :funobj flet-funobj))) do (movitz-env-add-binding flet-env flet-binding) collect `(:local-function-init ,flet-binding)))) (compiler-values-bind (&all body-values &code body-code) @@ -1089,7 +1080,7 @@ (destructuring-bind (symbols-form values-form &body body) (cdr form) (compiler-values-bind (&code body-code &returns body-returns) - (let ((body-env (make-instance 'with-things-on-stack-env + (let ((body-env (make-instance 'progv-env :uplink env :funobj funobj :stack-used t From ffjeld at common-lisp.net Mon Jan 3 11:55:53 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 3 Jan 2005 12:55:53 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: <20050103115553.620B3884FE@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv9130 Modified Files: special-operators.lisp Log Message: Started support for stack-allocating functions (of dynamic extent). Primary purpose is to evaluate e.g. handler-case without having to cons up a function for each handler. Date: Mon Jan 3 12:55:51 2005 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.45 movitz/special-operators.lisp:1.46 --- movitz/special-operators.lisp:1.45 Sat Nov 20 00:03:49 2004 +++ movitz/special-operators.lisp Mon Jan 3 12:55:36 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 20012000, 2002-2004, +;;;; Copyright (C) 20012000, 2002-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: special-operators.lisp @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.45 2004/11/19 23:03:49 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.46 2005/01/03 11:55:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1148,15 +1148,15 @@ :form keyform :result-mode :eax :forward all) +;;; (declare (ignore keyform-type)) ;;; (warn "keyform type: ~S" keyform-type) ;;; (warn "clause-types: ~S" (mapcar #'car clauses)) - (declare (ignore keyform-type)) + #+ignore (let ((clause (find 'muerte.cl::t clauses :key #'car))) (assert clause) (compiler-call #'compile-implicit-progn :form (cdr clause) :forward all)) - #+ignore (loop for (clause-type . clause-forms) in clauses when (movitz-subtypep (type-specifier-primary keyform-type) clause-type) return (compiler-call #'compile-implicit-progn @@ -1317,3 +1317,56 @@ :returns returns :code `((:eql ,x ,y ,returns)))))) + +(define-special-operator muerte::with-dynamic-extent-scope + (&all all &form form &env env &funobj funobj) + (destructuring-bind ((scope-tag) &body body) + (cdr form) + (let* ((save-esp-binding (make-instance 'located-binding + :name (gensym "dynamic-extent-save-esp-"))) + (base-binding (make-instance 'located-binding + :name (gensym "dynamic-extent-base-"))) + (scope-env + (make-local-movitz-environment env funobj + :type 'with-dynamic-extent-scope-env + :scope-tag scope-tag + :save-esp-binding save-esp-binding + :base-binding base-binding))) + (movitz-env-add-binding scope-env save-esp-binding) + (movitz-env-add-binding scope-env base-binding) + (compiler-values-bind (&code body-code &all body-values) + (compiler-call #'compile-implicit-progn + :env scope-env + :form body + :forward all) + (compiler-values (body-values) + :code (append `((:init-lexvar ,save-esp-binding + :init-with-register :esp + :init-with-type fixnum) + (:enter-dynamic-scope ,scope-env) + (:init-lexvar ,base-binding + :init-with-register :esp + :init-with-type fixnum)) + body-code + `((:load-lexical ,save-esp-binding :esp)))))))) + +(define-special-operator muerte::with-dynamic-extent-allocation + (&all all &form form &env env &funobj funobj) + (destructuring-bind ((scope-tag) &body body) + (cdr form) + (let* ((scope-env (loop for e = env then (movitz-environment-uplink e) + unless e + do (error "Dynamic-extent scope ~S not seen." scope-tag) + when (and (typep e 'with-dynamic-extent-scope-env) + (eq scope-tag (dynamic-extent-scope-tag e))) + return e)) + (allocation-env + (make-local-movitz-environment env funobj + :type 'with-dynamic-extent-allocation-env + :scope scope-env))) + (compiler-call #'compile-implicit-progn + :form body + :forward all + :env allocation-env)))) + + From ffjeld at common-lisp.net Mon Jan 3 11:56:05 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 3 Jan 2005 12:56:05 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: <20050103115605.0F6BA884A5@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv9148 Modified Files: storage-types.lisp Log Message: Started support for stack-allocating functions (of dynamic extent). Primary purpose is to evaluate e.g. handler-case without having to cons up a function for each handler. Date: Mon Jan 3 12:55:59 2005 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.47 movitz/storage-types.lisp:1.48 --- movitz/storage-types.lisp:1.47 Mon Dec 20 11:53:47 2004 +++ movitz/storage-types.lisp Mon Jan 3 12:55:57 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2000-2004, +;;;; Copyright (C) 2000-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: storage-types.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.47 2004/12/20 10:53:47 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.48 2005/01/03 11:55:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -760,6 +760,8 @@ :initarg :extent :initform :unused :accessor movitz-funobj-extent) + (allocation + :accessor movitz-allocation) (usage :initform nil :accessor movitz-funobj-usage) From ffjeld at common-lisp.net Mon Jan 3 11:56:17 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 3 Jan 2005 12:56:17 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp Message-ID: <20050103115617.56BFE884A5@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv9166 Modified Files: more-macros.lisp Log Message: Started support for stack-allocating functions (of dynamic extent). Primary purpose is to evaluate e.g. handler-case without having to cons up a function for each handler. Date: Mon Jan 3 12:56:16 2005 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.22 movitz/losp/muerte/more-macros.lisp:1.23 --- movitz/losp/muerte/more-macros.lisp:1.22 Thu Dec 9 15:20:43 2004 +++ movitz/losp/muerte/more-macros.lisp Mon Jan 3 12:56:14 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.22 2004/12/09 14:20:43 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.23 2005/01/03 11:56:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -104,10 +104,10 @@ (return t)))))))))) (define-compiler-macro dotimes (&whole form-decline (var count-form &optional result-form) - &body declarations-and-body) - (if (not (movitz:movitz-constantp count-form)) + &body declarations-and-body &environment env) + (if (not (movitz:movitz-constantp count-form env)) form-decline - (let ((count (movitz::eval-form count-form))) + (let ((count (movitz:movitz-eval count-form env))) (check-type count (integer 0 *)) (cond ((= 0 count) @@ -236,8 +236,6 @@ , at body) (setf (muerte::%run-time-context-slot 'bochs-flags) old-flags)))) - - (defmacro handler-bind (bindings &body forms) (if (null bindings) @@ -245,31 +243,14 @@ (labels ((make-handler (binding) (destructuring-bind (type handler) binding - (cond - #+ignore - ((and (listp handler) - (eq 'lambda (first handler)) - (= 1 (length (second handler)))) - `(cons t (lambda (x) - (when (typep x ',type) - (let ((,(first (second handler)) x)) - ,@(cddr handler))) - nil))) - #+ignore - ((and (listp handler) - (eq 'function (first handler)) - (listp (second handler)) - (eq 'lambda (first (second handler))) - (= 1 (length (second (second handler))))) - (make-handler (list type (second handler)))) - (t `(cons ',type ,handler)))))) - `(let ((*active-condition-handlers* - (cons (list ,@(mapcar #'make-handler #+ignore (lambda (binding) - `(cons ',(first binding) - ,(second binding))) - bindings)) - *active-condition-handlers*))) - , at forms)))) + `(cons ',type ,handler)))) + (let ((scope-tag (gensym "handler-bind-extent-scope-"))) + `(with-dynamic-extent-scope (,scope-tag) + (let ((*active-condition-handlers* + (with-dynamic-extent-allocation (,scope-tag) + (cons (list ,@(mapcar #'make-handler bindings)) + *active-condition-handlers*)))) + , at forms)))))) (defmacro handler-case (expression &rest clauses) (multiple-value-bind (normal-clauses no-error-clauses) From ffjeld at common-lisp.net Tue Jan 4 11:35:21 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 12:35:21 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050104113521.E22D2884F7@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18563 Modified Files: compiler.lisp Log Message: Added support for stack-allocated cons cells. Date: Tue Jan 4 12:35:11 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.124 movitz/compiler.lisp:1.125 --- movitz/compiler.lisp:1.124 Mon Jan 3 12:55:04 2005 +++ movitz/compiler.lisp Tue Jan 4 12:35:10 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.124 2005/01/03 11:55:04 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.125 2005/01/04 11:35:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -649,6 +649,10 @@ (case (car instruction) (:call-lexical (process-binding funobj (second instruction) '(:call))) + (:stack-cons + (destructuring-bind (proto-cons dynamic-scope) + (cdr instruction) + (push proto-cons (dynamic-extent-scope-members dynamic-scope)))) (:load-lambda (destructuring-bind (lambda-binding lambda-result-mode capture-env) (cdr instruction) @@ -656,15 +660,13 @@ (assert (eq funobj (binding-funobj lambda-binding)) () "A non-local lambda doesn't make sense. There must be a bug.") (let ((lambda-funobj (function-binding-funobj lambda-binding))) - (let ((dynamic-extent (dynamic-extent-allocation capture-env))) - (when dynamic-extent - (let ((dynamic-scope (allocation-env-scope dynamic-extent))) - ;; (warn "Adding ~S to ~S/~S" lambda-funobj dynamic-extent dynamic-scope) - (setf (movitz-funobj-extent lambda-funobj) :dynamic-extent - (movitz-allocation lambda-funobj) dynamic-scope) - (push lambda-funobj - (dynamic-extent-scope-members (allocation-env-scope dynamic-extent))) - (process-binding funobj (base-binding dynamic-scope) '(:read))))) + (let ((dynamic-scope (find-dynamic-extent-scope capture-env))) + (when dynamic-scope + ;; (warn "Adding ~S to ~S/~S" lambda-funobj dynamic-extent dynamic-scope) + (setf (movitz-funobj-extent lambda-funobj) :dynamic-extent + (movitz-allocation lambda-funobj) dynamic-scope) + (push lambda-funobj (dynamic-extent-scope-members dynamic-scope)) + (process-binding funobj (base-binding dynamic-scope) '(:read)))) (resolve-sub-funobj funobj lambda-funobj) (process-binding funobj lambda-binding '(:read)) ;; This funobj is effectively using every binding that the lambda @@ -3841,7 +3843,6 @@ (destructuring-bind (function-binding register capture-env) (operands instruction) (declare (ignore capture-env)) - ;; (warn "load-lambda not completed for ~S" function-binding) (finalize-code (let* ((sub-funobj (function-binding-funobj function-binding)) (lend-code (loop for bb in (borrowed-bindings sub-funobj) @@ -6896,6 +6897,9 @@ (loop for object in (reverse (dynamic-extent-scope-members scope-env)) appending (etypecase object + (movitz-cons + `((:pushl :edi) + (:pushl :edi))) (movitz-funobj (append (unless (zerop (mod (sizeof object) 8)) `((:pushl :edi))) @@ -6932,3 +6936,19 @@ (when (eq t distance) (values (list (movitz-binding (save-esp-variable to-env) to-env nil)) (list :esp))))) + +(define-find-read-bindings :stack-cons (proto-cons scope-env) + (declare (ignore proto-cons)) + (values (list (base-binding scope-env)) + (list :edx))) + +(define-extended-code-expander :stack-cons (instruction funobj frame-map) + (destructuring-bind (proto-cons dynamic-scope) + (cdr instruction) + (append (make-load-lexical (base-binding dynamic-scope) :edx + funobj nil frame-map) + `((:movl :eax (:edx ,(dynamic-extent-object-offset dynamic-scope proto-cons))) + (:movl :ebx (:edx ,(+ 4 (dynamic-extent-object-offset dynamic-scope proto-cons)))) + (:leal (:edx ,(+ (tag :cons) (dynamic-extent-object-offset dynamic-scope proto-cons))) + :eax))))) + From ffjeld at common-lisp.net Tue Jan 4 11:35:44 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 12:35:44 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/environment.lisp Message-ID: <20050104113544.B3DA5884F7@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18581 Modified Files: environment.lisp Log Message: Added support for stack-allocated cons cells. Date: Tue Jan 4 12:35:38 2005 Author: ffjeld Index: movitz/environment.lisp diff -u movitz/environment.lisp:1.11 movitz/environment.lisp:1.12 --- movitz/environment.lisp:1.11 Mon Jan 3 12:55:13 2005 +++ movitz/environment.lisp Tue Jan 4 12:35:25 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 3 11:40:15 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: environment.lisp,v 1.11 2005/01/03 11:55:13 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.12 2005/01/04 11:35:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -142,11 +142,11 @@ :initform nil :accessor dynamic-extent-scope-members))) -(defun dynamic-extent-allocation (env) +(defun find-dynamic-extent-scope (env) (loop for e = env then (movitz-environment-uplink e) while e do (when (typep e 'with-dynamic-extent-allocation-env) - (return e)))) + (return (allocation-env-scope e))))) (defun dynamic-extent-object-offset (scope-env object) (loop with offset = 0 From ffjeld at common-lisp.net Tue Jan 4 11:35:55 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 12:35:55 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: <20050104113555.D24BA884F7@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18604 Modified Files: special-operators.lisp Log Message: Added support for stack-allocated cons cells. Date: Tue Jan 4 12:35:52 2005 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.46 movitz/special-operators.lisp:1.47 --- movitz/special-operators.lisp:1.46 Mon Jan 3 12:55:36 2005 +++ movitz/special-operators.lisp Tue Jan 4 12:35:48 2005 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.46 2005/01/03 11:55:36 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.47 2005/01/04 11:35:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1370,3 +1370,23 @@ :env allocation-env)))) +(define-special-operator muerte::compiled-cons + (&all all &form form &env env &funobj funobj) + (destructuring-bind (car cdr) + (cdr form) + (let ((dynamic-extent-scope (find-dynamic-extent-scope env))) + (cond + (dynamic-extent-scope + (compiler-values () + :returns :eax + :functional-p t + :type 'cons + :code (append (make-compiled-two-forms-into-registers car :eax cdr :ebx funobj env) + `((:stack-cons ,(make-instance 'movitz-cons) + ,dynamic-extent-scope))))) + (t (compiler-values () + :returns :eax + :functional-p t + :type 'cons + :code (append (make-compiled-two-forms-into-registers car :eax cdr :ebx funobj env) + `((:globally (:call (:edi (:edi-offset fast-cons)))))))))))) From ffjeld at common-lisp.net Tue Jan 4 11:36:17 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 12:36:17 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: <20050104113617.271E9884F7@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18621 Modified Files: basic-macros.lisp Log Message: Added support for stack-allocated cons cells. Date: Tue Jan 4 12:36:11 2005 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.53 movitz/losp/muerte/basic-macros.lisp:1.54 --- movitz/losp/muerte/basic-macros.lisp:1.53 Thu Dec 9 15:20:14 2004 +++ movitz/losp/muerte/basic-macros.lisp Tue Jan 4 12:36:09 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2000-2004, +;;;; Copyright (C) 2000-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: basic-macros.lisp @@ -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.53 2004/12/09 14:20:14 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.54 2005/01/04 11:36:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -662,10 +662,14 @@ (do-case (t :same) (:endp (:lexical-binding cell) (:returns-mode)))))) -(define-compiler-macro cons (x y) - `(with-inline-assembly (:returns :eax :side-effects nil :type cons) - (:compile-two-forms (:eax :ebx) ,x ,y) - (:globally (:call (:edi (:edi-offset fast-cons)))))) +(define-compiler-macro cons (car cdr) + `(compiled-cons ,car ,cdr)) + +(define-compiler-macro list (&whole form &rest elements &environment env) + (case (length elements) + (0 nil) + (1 `(cons ,(car elements) nil)) + (t form))) #+ignore (define-compiler-macro apply (&whole form function &rest args) From ffjeld at common-lisp.net Tue Jan 4 16:53:47 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 17:53:47 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050104165347.F3118884F7@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv1713 Modified Files: compiler.lisp Log Message: Fixing dynamic control transfers, primarily to handle the stack-allocated funobjs, but there seems to be a number of (other) bugs here too. It's not quite working yet, though. Date: Tue Jan 4 17:53:46 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.125 movitz/compiler.lisp:1.126 --- movitz/compiler.lisp:1.125 Tue Jan 4 12:35:10 2005 +++ movitz/compiler.lisp Tue Jan 4 17:53:46 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.125 2005/01/04 11:35:10 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.126 2005/01/04 16:53:46 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5912,6 +5912,8 @@ "Lexical unwind-protect not implemented, to-env: ~S. (this is not supposed to happen)" to-env) ;; (warn "dist: ~S, slots: ~S" stack-distance num-dynamic-slots) + (assert (not (eq t num-dynamic-slots)) () + "Don't know how to make lexical-control-transfer across unknown number of dynamic slots.") (cond ((and (eq t stack-distance) (eql 0 num-dynamic-slots)) @@ -5921,8 +5923,7 @@ (unless (eq :function (exit-result-mode to-env)) `((:load-lexical ,(movitz-binding (save-esp-variable to-env) to-env nil) :esp))) `((:jmp ',to-label))))) - ((or (eq t stack-distance) - (eq t num-dynamic-slots)) + ((eq t stack-distance) (compiler-values () :returns :non-local-exit :code (append return-code From ffjeld at common-lisp.net Tue Jan 4 16:53:56 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 17:53:56 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: <20050104165356.DBCDF8864E@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv1732 Modified Files: image.lisp Log Message: Fixing dynamic control transfers, primarily to handle the stack-allocated funobjs, but there seems to be a number of (other) bugs here too. It's not quite working yet, though. Date: Tue Jan 4 17:53:54 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.86 movitz/image.lisp:1.87 --- movitz/image.lisp:1.86 Wed Dec 15 14:58:08 2004 +++ movitz/image.lisp Tue Jan 4 17:53:53 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001,2000, 2002-2004, +;;;; Copyright (C) 2001,2000, 2002-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; Filename: image.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.86 2004/12/15 13:58:08 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.87 2005/01/04 16:53:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -477,6 +477,11 @@ :binary-type word :initform 0) (ret-trampoline + :binary-type code-vector-word + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (dynamic-jump-next :binary-type code-vector-word :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector From ffjeld at common-lisp.net Tue Jan 4 16:54:04 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 17:54:04 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp Message-ID: <20050104165404.8C45688649@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv1757 Modified Files: special-operators-cl.lisp Log Message: Fixing dynamic control transfers, primarily to handle the stack-allocated funobjs, but there seems to be a number of (other) bugs here too. It's not quite working yet, though. Date: Tue Jan 4 17:54:03 2005 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.40 movitz/special-operators-cl.lisp:1.41 --- movitz/special-operators-cl.lisp:1.40 Mon Jan 3 12:55:27 2005 +++ movitz/special-operators-cl.lisp Tue Jan 4 17:54:02 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.40 2005/01/03 11:55:27 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.41 2005/01/04 16:54:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -749,35 +749,43 @@ (movitz-env-get tag 'go-tag nil env) (assert (and label tagbody-env) () "Go-tag ~W is not visible." tag) - (if (and (eq funobj (movitz-environment-funobj tagbody-env)) - ;; any unwind-protects between here and there? - (null (nth-value 2 (stack-delta env tagbody-env)))) - (compiler-values () - :returns :non-local-exit - :code `((:lexical-control-transfer nil :nothing ,env ,tagbody-env ,label))) - ;; Perform a lexical "throw" to the tag. Just like a regular (dynamic) throw. - (let ((save-esp-binding (movitz-binding (save-esp-variable tagbody-env) env)) - (label-id (movitz-env-get tag 'go-tag-label-id nil tagbody-env nil))) - (assert label-id) - (compiler-values () - :returns :non-local-exit - :code `((:load-lexical ,save-esp-binding :edx) - (:movl :edx :eax) - ,@(when (plusp label-id) - ;; The target jumper points to the tagbody's label-set. - ;; Now, install correct jumper within tagbody as target. - `((:addl ,(* 4 label-id) (:edx 8)))) - (:locally (:call (:edi (:edi-offset dynamic-unwind-next)))) - ;; have next-continuation in EAX, final-continuation in EDX - (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation - (:locally (:movl :esi (:edi (:edi-offset scratch1)))) - (:locally (:movl :eax (:edi (:edi-offset dynamic-env)))) ; exit to next-env - (:movl :eax :esp) ; enter non-local jump stack mode. - (:movl (:esp) :eax) ; target stack-frame EBP - (:movl (:eax -4) :esi) ; get target funobj into ESI - (:movl (:esp 8) :eax) ; target jumper number - (:clc) - (:jmp (:esi :eax ,(slot-offset 'movitz-funobj 'constant0)))))))))) + (multiple-value-bind (stack-distance num-dynamic-slots unwind-protects) + (stack-delta env tagbody-env) + (declare (ignore stack-distance)) + (if (and (eq funobj (movitz-environment-funobj tagbody-env)) + ;; A well-known number of dynamic-slots? + (not (eq t num-dynamic-slots)) + ;; any unwind-protects between here and there? + (null unwind-protects)) + (compiler-values () + :returns :non-local-exit + :code `((:lexical-control-transfer nil :nothing ,env ,tagbody-env ,label))) + ;; Perform a lexical "throw" to the tag. Just like a regular (dynamic) throw. + (let ((save-esp-binding (movitz-binding (save-esp-variable tagbody-env) env)) + (label-id (movitz-env-get tag 'go-tag-label-id nil tagbody-env nil))) + (assert label-id) + (compiler-values () + :returns :non-local-exit + :code `((:load-lexical ,save-esp-binding :edx) + (:movl :edx :eax) + ,@(when (plusp label-id) + ;; The target jumper points to the tagbody's label-set. + ;; Now, install correct jumper within tagbody as target. + `((:addl ,(* 4 label-id) (:edx 8)))) + (:locally (:call (:edi (:edi-offset dynamic-unwind-next)))) + ;; have next-continuation in EAX, final-continuation in EDX + (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation + + (:movl :eax :edx) + (:clc) + (:locally (:call (:edi (:edi-offset dynamic-jump-next)))))))))))) + +;;; (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit to next-env +;;; (:movl :edx :esp) ; enter non-local jump stack mode. +;;; (:movl (:esp) :edx) ; target stack-frame EBP +;;; (:movl (:edx -4) :esi) ; get target funobj into ESI +;;; (:movl (:esp 8) :edx) ; target jumper number +;;; (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0))))))))))) (define-special-operator block (&all forward &funobj funobj &form form &env env &result-mode result-mode) @@ -849,10 +857,10 @@ new-code ;; wrapped-code `(,exit-block-label + (:movl (:esp 0) :ebp) (:movl (:esp 12) :edx) (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) - (:popl :ebp) - (:leal (:esp 12) :esp))) + (:leal (:esp 16) :esp))) :returns :multiple-values :functional-p block-no-side-effects-p)))))))) @@ -1225,92 +1233,98 @@ (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) ; install catch body-code `(,exit-point + (:movl (:esp) :ebp) (:movl (:esp 12) :edx) (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) - (:popl :ebp) - (:leal (:esp 12) :esp) + (:leal (:esp 16) :esp) ))))) (define-special-operator unwind-protect (&all all &form form &env env) (destructuring-bind (protected-form &body cleanup-forms) (cdr form) - (let* ((continuation-env (make-instance 'let-env - :uplink env - :funobj (movitz-environment-funobj env))) - (next-continuation-step-binding - (movitz-env-add-binding continuation-env - (make-instance 'located-binding - :name (gensym "up-next-continuation-step-")))) - (unwind-protect-env (make-instance 'unwind-protect-env - :cleanup-form (cons 'muerte.cl:progn cleanup-forms) - :uplink continuation-env - :funobj (movitz-environment-funobj env)))) - (with-labels (unwind-protect (cleanup-label cleanup-entry continue continue-label)) - (compiler-values () - :returns :multiple-values - :code (append - ;; install default continuation dynamic-env.. - `((:locally (:pushl (:edi (:edi-offset dynamic-env)))) - (:declare-label-set ,cleanup-label (,cleanup-entry)) - (:declare-label-set ,continue-label (,continue)) - (:pushl ',cleanup-label) ; jumper index - (:globally (:pushl (:edi (:edi-offset unwind-protect-tag)))) ; tag - (:pushl :ebp) ; stack-frame - (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) ; install up-env - ;; Execute protected form.. - (compiler-call #'compile-form - :env unwind-protect-env - :with-stack-used t ;; XXX Not really true, is it? - :forward all - :result-mode :multiple-values - :form protected-form) - ;; From now on, take care not to touch current-values from protected-form. - `((:locally (:movl :esp (:edi (:edi-offset raw-scratch0)))) - ,cleanup-entry - - ;; Now (?), modify unwind-protect dyn-env-entry to be normal continuation - (:locally (:movl (:edi (:edi-offset unbound-function)) :edx)) - (:movl :edx (:esp 4)) ; not unwind-protect-tag - (:movl ',continue-label (:esp 8)) ; new jumper index - - (:locally (:pushl (:edi (:edi-offset raw-scratch0))))) ; push final-continuation - ;; Execute cleanup-forms. - (compiler-call #'compile-form-unprotected - :forward all - :env continuation-env - :with-stack-used t - :result-mode :multiple-values - :form `(muerte::with-cloak (:multiple-values) - ;; Inside here we don't have to mind current-values. - (muerte::with-inline-assembly (:returns :nothing) - ;; First, find next-continuation-step.. - (:locally (:movl (:edi (:edi-offset raw-scratch0)) :eax)) ; final-cont.. - (:locally (:call (:edi (:edi-offset dynamic-unwind-next)))) - (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax)) - (:store-lexical ,next-continuation-step-binding :eax :type t)) - , at cleanup-forms)) - `((:locally (:popl (:edi (:edi-offset raw-scratch0)))) ; pop final continuation + (if (null cleanup-forms) + (compiler-call #'compile-form-unprotected + :forward all + :form protected-form) + (let* ((continuation-env (make-instance 'let-env + :uplink env + :funobj (movitz-environment-funobj env))) + (next-continuation-step-binding + (movitz-env-add-binding continuation-env + (make-instance 'located-binding + :name (gensym "up-next-continuation-step-")))) + (unwind-protect-env (make-instance 'unwind-protect-env + :cleanup-form (cons 'muerte.cl:progn cleanup-forms) + :uplink continuation-env + :funobj (movitz-environment-funobj env)))) + (with-labels (unwind-protect (cleanup-label cleanup-entry continue continue-label)) + (compiler-values () + :returns :multiple-values + :code (append + ;; install default continuation dynamic-env.. + `((:locally (:pushl (:edi (:edi-offset dynamic-env)))) + (:declare-label-set ,cleanup-label (,cleanup-entry)) + (:declare-label-set ,continue-label (,continue)) + (:pushl ',cleanup-label) ; jumper index + (:globally (:pushl (:edi (:edi-offset unwind-protect-tag)))) ; tag + (:pushl :ebp) ; stack-frame + (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) ; install up-env + ;; Execute protected form.. + (compiler-call #'compile-form + :env unwind-protect-env + :with-stack-used t ;; XXX Not really true, is it? + :forward all + :result-mode :multiple-values + :form protected-form) + ;; From now on, take care not to touch current-values from protected-form. + `((:locally (:movl :esp (:edi (:edi-offset raw-scratch0)))) + ,cleanup-entry + ;; First, restore stack-frame in EBP + (:movl (:esp) :ebp) + ;; Now (?), modify unwind-protect dyn-env-entry to be normal continuation + (:locally (:movl (:edi (:edi-offset unbound-function)) :edx)) + (:movl :edx (:esp 4)) ; not unwind-protect-tag + (:movl ',continue-label (:esp 8)) ; new jumper index + + (:locally (:pushl (:edi (:edi-offset raw-scratch0))))) ; push final-continuation + ;; Execute cleanup-forms. + (compiler-call #'compile-form-unprotected + :forward all + :env continuation-env + :with-stack-used t + :result-mode :multiple-values + :form `(muerte::with-cloak (:multiple-values) + ;; Inside here we don't have to mind current-values. + (muerte::with-inline-assembly (:returns :nothing) + ;; First, find next-continuation-step.. + (:locally (:movl (:edi (:edi-offset raw-scratch0)) :eax)) ; final-cont.. + (:locally (:call (:edi (:edi-offset dynamic-unwind-next)))) + (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax)) + (:store-lexical ,next-continuation-step-binding :eax :type t)) + , at cleanup-forms)) + `((:locally (:popl (:edi (:edi-offset raw-scratch0)))) ; pop final continuation ;;; ;; Now (?), modify unwind-protect dyn-env-entry to be normal continuation ;;; (:locally (:movl (:edi (:edi-offset unbound-value)) :edx)) ;;; (:movl :edx (:esp 4)) ; not unwind-protect-tag ;;; (:movl ',continue-label (:esp 8)) ; new jumper index - (:load-lexical ,next-continuation-step-binding :edx) - (:locally (:movl :esi (:edi (:edi-offset scratch1)))) - (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) - (:movl :edx :esp) ; enter non-local jump stack mode (possibly). - - (:movl (:esp) :edx) ; target stack-frame EBP - (:movl (:edx -4) :esi) ; get target funobj into EDX - - (:movl (:esp 8) :edx) ; target jumper number - (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0)))) - `(,continue - (:movl (:esp 12) :edx) - (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) - (:popl :ebp) - (:leal (:esp 12) :esp)))))))) + (:load-lexical ,next-continuation-step-binding :edx) + (:locally (:call (:edi (:edi-offset dynamic-jump-next)))) + +;;; (:locally (:movl :esi (:edi (:edi-offset scratch1)))) +;;; (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) +;;; (:movl :edx :esp) ; enter non-local jump stack mode (possibly). +;;; (:movl (:esp) :edx) ; target stack-frame EBP +;;; (:movl (:edx -4) :esi) ; get target funobj into EDX +;;; (:movl (:esp 8) :edx) ; target jumper number +;;; (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0))) + ) + `(,continue + (:movl (:esp) :ebp) + (:movl (:esp 12) :edx) + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) + (:leal (:esp 16) :esp))))))))) (define-special-operator if (&all all &form form &env env &result-mode result-mode) (destructuring-bind (test-form then-form &optional else-form) From ffjeld at common-lisp.net Tue Jan 4 16:54:11 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 17:54:11 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: <20050104165411.F18548864B@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv1776 Modified Files: special-operators.lisp Log Message: Fixing dynamic control transfers, primarily to handle the stack-allocated funobjs, but there seems to be a number of (other) bugs here too. It's not quite working yet, though. Date: Tue Jan 4 17:54:11 2005 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.47 movitz/special-operators.lisp:1.48 --- movitz/special-operators.lisp:1.47 Tue Jan 4 12:35:48 2005 +++ movitz/special-operators.lisp Tue Jan 4 17:54:10 2005 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.47 2005/01/04 11:35:48 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.48 2005/01/04 16:54:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1210,15 +1210,17 @@ `((:load-lexical ,dynamic-slot-binding :edx) (:locally (:movl :edx (:edi (:edi-offset raw-scratch0)))) ; final continuation (:load-lexical ,next-continuation-step-binding :edx) ; next continuation-step - (:locally (:movl :esi (:edi (:edi-offset scratch1)))) - (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit dynamic-env - (:movl :edx :esp) ; enter non-local jump stack mode. - - (:movl (:esp) :edx) ; target stack-frame EBP - (:movl (:edx -4) :esi) ; get target funobj into ESI - - (:movl (:esp 8) :edx) ; target jumper number - (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0))))))))) + (:locally (:call (:edi (:edi-offset dynamic-jump-next)))))))))) + +;;; (:locally (:movl :esi (:edi (:edi-offset scratch1)))) + + +;;; (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit dynamic-env +;;; (:movl :edx :esp) ; enter non-local jump stack mode. +;;; (:movl (:esp) :edx) ; target stack-frame EBP +;;; (:movl (:edx -4) :esi) ; get target funobj into ESI +;;; (:movl (:esp 8) :edx) ; target jumper number +;;; (:jmp (:esi :edx ,(slot-offset 'movitz-funobj 'constant0))))))))) (define-special-operator muerte::with-basic-restart (&all defaults &form form &env env) @@ -1297,10 +1299,10 @@ :form body) `((:leal (:esp ,(+ -12 -4 (* 4 entry-size))) :esp) ,exit-point + (:movl (:esp) :ebp) (:movl (:esp 12) :edx) (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) - (:popl :ebp) - (:leal (:esp 12) :esp) + (:leal (:esp 16) :esp) ))))))) From ffjeld at common-lisp.net Tue Jan 4 16:54:17 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 17:54:17 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: <20050104165417.F03D9884F7@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1793 Modified Files: interrupt.lisp Log Message: Fixing dynamic control transfers, primarily to handle the stack-allocated funobjs, but there seems to be a number of (other) bugs here too. It's not quite working yet, though. Date: Tue Jan 4 17:54:17 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.33 movitz/losp/muerte/interrupt.lisp:1.34 --- movitz/losp/muerte/interrupt.lisp:1.33 Tue Nov 23 17:05:59 2004 +++ movitz/losp/muerte/interrupt.lisp Tue Jan 4 17:54:16 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2003-2004, +;;;; Copyright (C) 2003-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.33 2004/11/23 16:05:59 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.34 2005/01/04 16:54:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,6 +25,7 @@ :ebp :funobj :edi + :dynamic-env :atomically-continuation :raw-scratch0 :ecx :eax :edx :ebx :esi @@ -78,6 +79,8 @@ (let ((ebp (dit-frame-ref stack dit-frame :ebp)) (esp (dit-frame-esp stack dit-frame))) (cond + ((null ebp) ; special mode + (stack-frame-ref stack (dit-frame-ref stack dit-frame :dynamic-env) 0)) ((< esp ebp) ebp) ((> esp ebp) @@ -118,6 +121,7 @@ (:pushl 0) ; 0 'funobj' means default-interrupt-trampoline frame (:pushl :edi) ; (:movl ':nil-value :edi) ; We want NIL! + (:locally (:pushl (:edi (:edi-offset dynamic-env)))) (:locally (:pushl (:edi (:edi-offset atomically-continuation)))) (:locally (:pushl (:edi (:edi-offset raw-scratch0)))) ,@(loop for reg in (sort (copy-list '(:eax :ebx :ecx :edx :esi)) @@ -206,6 +210,12 @@ ;; Interrupted code was non-atomical, the normal case. normal-return + (:movl (:ebp ,(dit-frame-offset :dynamic-env)) :ecx) + (:locally (:cmpl :ecx (:edi (:edi-offset dynamic-env)))) + (:jne '(:sub-program () + ;; This would mean the interrupt handled failed to reset dynamic-env. + (:int 63))) + ;; (:locally (:movl :ecx (:edi (:edi-offset dynamic-env)))) (:movl (:ebp ,(dit-frame-offset :raw-scratch0)) :ecx) (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) (:movl (:ebp ,(dit-frame-offset :scratch1)) :eax) From ffjeld at common-lisp.net Tue Jan 4 16:54:24 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 17:54:24 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: <20050104165424.F39518864B@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1808 Modified Files: primitive-functions.lisp Log Message: Fixing dynamic control transfers, primarily to handle the stack-allocated funobjs, but there seems to be a number of (other) bugs here too. It's not quite working yet, though. Date: Tue Jan 4 17:54:21 2005 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.58 movitz/losp/muerte/primitive-functions.lisp:1.59 --- movitz/losp/muerte/primitive-functions.lisp:1.58 Tue Dec 14 17:22:08 2004 +++ movitz/losp/muerte/primitive-functions.lisp Tue Jan 4 17:54:20 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.58 2004/12/14 16:22:08 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.59 2005/01/04 16:54:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -678,3 +678,17 @@ "This is the global RET trampoline, used to achieve stack discipline." (with-inline-assembly (:returns :multiple-values) (:ret))) + +(define-primitive-function dynamic-jump-next () + "Transfer control to (next) dynamic control transfer target in EDX. +Final target is in raw-scratch0. Doesn't modify current-values." + (with-inline-assembly (:returns :non-local-exit) + (:movl :edi :esi) ; before bumping ESP, remove reference to funobj.. + ; ..in case it's stack-allocated. + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) ; exit to next-env + (:movl :edi :ebp) ; enter non-local jump stack mode. + (:movl :edx :esp) ; + (:movl (:esp) :edx) ; target stack-frame EBP + (:movl (:edx -4) :esi) ; get target funobj into ESI + (:movl (:esp 8) :edx) ; target jumper number + (:jmp (:esi :edx (:offset movitz-funobj constant0))))) From ffjeld at common-lisp.net Tue Jan 4 16:54:31 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 17:54:31 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: <20050104165431.662FF884F7@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1825 Modified Files: scavenge.lisp Log Message: Fixing dynamic control transfers, primarily to handle the stack-allocated funobjs, but there seems to be a number of (other) bugs here too. It's not quite working yet, though. Date: Tue Jan 4 17:54:28 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.38 movitz/losp/muerte/scavenge.lisp:1.39 --- movitz/losp/muerte/scavenge.lisp:1.38 Mon Jan 3 12:53:47 2005 +++ movitz/losp/muerte/scavenge.lisp Tue Jan 4 17:54:27 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2003-2004, +;;;; Copyright (C) 2003-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.38 2005/01/03 11:53:47 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.39 2005/01/04 16:54:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -204,10 +204,11 @@ (+ dit-frame (dit-frame-index :ecx))))) ;; 2. Pop to (dit-)frame's CASF (setf nether-frame dit-frame - frame (dit-frame-casf stack frame)) - (let ((casf-funobj (funcall function (stack-frame-funobj stack frame) frame)) + frame casf-frame #+ignore (dit-frame-casf stack frame)) + (let ((eip-location (dit-frame-ref stack dit-frame :eip :location)) + (interrupted-esp (dit-frame-esp stack dit-frame)) (interrupted-ebp (dit-frame-ref stack dit-frame :ebp)) - (interrupted-esp (dit-frame-esp stack dit-frame))) + (casf-funobj (funcall function (stack-frame-funobj stack frame) frame))) (cond #+ignore ((eq nil casf-funobj) @@ -218,23 +219,21 @@ (let ((casf-code-vector (scavenge-funobj-code-vector casf-funobj))) ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. (cond - ((< interrupted-ebp interrupted-esp) + ((eq nil interrupted-ebp) (cond - ((location-in-object-p casf-code-vector - (dit-frame-ref stack dit-frame :eip :location)) - (warn "DIT at throw situation, in target EIP=~S" + ((location-in-object-p casf-code-vector eip-location) + (warn "DIT at throw situation, in target ~S at ~S" + casf-funobj (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) (map-region function interrupted-esp frame)) - ((location-in-object-p (scavenge-funobj-code-vector (dit-frame-ref stack - dit-frame - :scratch1)) - (dit-frame-ref stack dit-frame :eip :location)) - (warn "DIT at throw situation, in thrower EIP=~S" - (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) - (map-region function interrupted-esp frame)) - (t (error "DIT with EBP Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv1840 Modified Files: debugger.lisp Log Message: Fixing dynamic control transfers, primarily to handle the stack-allocated funobjs, but there seems to be a number of (other) bugs here too. It's not quite working yet, though. Date: Tue Jan 4 17:54:35 2005 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.27 movitz/losp/x86-pc/debugger.lisp:1.28 --- movitz/losp/x86-pc/debugger.lisp:1.27 Thu Oct 21 22:27:00 2004 +++ movitz/losp/x86-pc/debugger.lisp Tue Jan 4 17:54:34 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.27 2004/10/21 20:27:00 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.28 2005/01/04 16:54:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -470,6 +470,8 @@ for frame = initial-stack-frame-index then (or next-frame (let ((uplink (stack-frame-uplink stack frame))) + (assert (typep uplink 'fixnum) () + "Weird uplink ~S for frame ~S." uplink frame) (assert (> uplink frame) () "Backtracing uplink ~S from frame index ~S." uplink frame) uplink)) From ffjeld at common-lisp.net Tue Jan 4 16:56:20 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 17:56:20 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/more-macros.lisp Message-ID: <20050104165620.5BF21884F7@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv1862 Modified Files: more-macros.lisp Log Message: Small fix for the %run-time-context-slot compiler-macro and :code-vector-word slots. Date: Tue Jan 4 17:56:19 2005 Author: ffjeld Index: movitz/losp/muerte/more-macros.lisp diff -u movitz/losp/muerte/more-macros.lisp:1.23 movitz/losp/muerte/more-macros.lisp:1.24 --- movitz/losp/muerte/more-macros.lisp:1.23 Mon Jan 3 12:56:14 2005 +++ movitz/losp/muerte/more-macros.lisp Tue Jan 4 17:56:19 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Jun 7 15:05:57 2002 ;;;; -;;;; $Id: more-macros.lisp,v 1.23 2005/01/03 11:56:14 ffjeld Exp $ +;;;; $Id: more-macros.lisp,v 1.24 2005/01/04 16:56:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -342,8 +342,8 @@ (:locally (:movl (:edi (:edi-offset ,slot-name)) :eax)))) (movitz::code-vector-word `(with-inline-assembly (:returns :eax) - (:locally (:movl (:edi (:edi-offset ,slot-name)) :eax)) - (:subl ,movitz::+code-vector-word-offset+ :eax))) + (:movl ,(ldb (byte 32 0) (- movitz::+code-vector-word-offset+)) :eax) + (:locally (:addl (:edi (:edi-offset ,slot-name)) :eax)))) (movitz::lu32 `(with-inline-assembly (:returns :untagged-fixnum-ecx) (:locally (:movl (:edi (:edi-offset ,slot-name)) :ecx)))))))) From ffjeld at common-lisp.net Tue Jan 4 16:56:46 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 17:56:46 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp Message-ID: <20050104165646.589B4884F7@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv1885 Modified Files: procfs-image.lisp Log Message: We have bignums, too. Date: Tue Jan 4 17:56:45 2005 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.21 movitz/procfs-image.lisp:1.22 --- movitz/procfs-image.lisp:1.21 Tue Nov 23 17:11:31 2004 +++ movitz/procfs-image.lisp Tue Jan 4 17:56:44 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.21 2004/11/23 16:11:31 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.22 2005/01/04 16:56:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -124,6 +124,8 @@ (movitz-vector-symbolic-data expr))) (movitz-fixnum (movitz-fixnum-value expr)) + (movitz-bignum + (movitz-bignum-value expr)) (movitz-basic-vector (map 'vector #'movitz-print (movitz-vector-symbolic-data expr))) (movitz-cons From ffjeld at common-lisp.net Tue Jan 4 20:21:18 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 21:21:18 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050104202118.1F287880E6@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12548 Modified Files: compiler.lisp Log Message: Fixed bug in make-compiled-lexical-control-transfer that would cause ESP not to be reset correctly in some situations. Date: Tue Jan 4 21:21:11 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.126 movitz/compiler.lisp:1.127 --- movitz/compiler.lisp:1.126 Tue Jan 4 17:53:46 2005 +++ movitz/compiler.lisp Tue Jan 4 21:21:11 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.126 2005/01/04 16:53:46 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.127 2005/01/04 20:21:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5950,7 +5950,7 @@ return-mode) `((:jmp ',to-label))))) ((plusp num-dynamic-slots) - ;; (warn "num-dynamic-slots: ~S" num-dynamic-slots) + ;; (warn "num-dynamic-slots: ~S, distance: ~D" num-dynamic-slots stack-distance) (compiler-values () :returns :non-local-exit :code (append return-code @@ -5966,10 +5966,8 @@ (:locally (:call (:edi (:edi-offset dynamic-unwind-next)))) (:locally (:movl :eax (:edi (:edi-offset dynamic-env)))) (:jc '(:sub-program () (:int 63)))))) - (make-compiled-stack-restore stack-distance - (exit-result-mode to-env) - return-mode) - `((:jmp ',to-label))))) + `((:leal (:esp ,(* 4 stack-distance)) :esp) + (:jmp ',to-label))))) (t (error "unknown!"))))) (defun make-compiled-push-current-values () From ffjeld at common-lisp.net Tue Jan 4 20:22:03 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 21:22:03 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp Message-ID: <20050104202203.E8DE7880E6@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12579 Modified Files: special-operators-cl.lisp Log Message: Have tagbody set up a dynamic control transfer target properly. Date: Tue Jan 4 21:22:02 2005 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.41 movitz/special-operators-cl.lisp:1.42 --- movitz/special-operators-cl.lisp:1.41 Tue Jan 4 17:54:02 2005 +++ movitz/special-operators-cl.lisp Tue Jan 4 21:22:00 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.41 2005/01/04 16:54:02 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.42 2005/01/04 20:22:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -722,7 +722,7 @@ ;; catcher (:locally (:pushl (:edi (:edi-offset dynamic-env)))) (:pushl ',label-set-name) - (:pushl :eax) + (:locally (:pushl (:edi (:edi-offset unbound-function)))) (:pushl :ebp) (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) maybe-store-esp-code From ffjeld at common-lisp.net Tue Jan 4 20:23:18 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 21:23:18 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp Message-ID: <20050104202318.62965880E6@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv12597 Modified Files: los-closette.lisp Log Message: It's probably a good idea to signal an error when trying to print an illegal-value. Date: Tue Jan 4 21:23:17 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.24 movitz/losp/muerte/los-closette.lisp:1.25 --- movitz/losp/muerte/los-closette.lisp:1.24 Mon Dec 20 14:42:51 2004 +++ movitz/losp/muerte/los-closette.lisp Tue Jan 4 21:23:16 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.24 2004/12/20 13:42:51 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.25 2005/01/04 20:23:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1723,7 +1723,8 @@ x) (defmethod print-object ((x illegal-object) stream) - (print-unreadable-object (x stream :type t :identity t)) + (error "Won't print illegal-object ~Z." x) + ;; (print-unreadable-object (x stream :type t :identity t)) x) ;;; From ffjeld at common-lisp.net Tue Jan 4 20:24:01 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 21:24:01 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/los0.lisp Message-ID: <20050104202401.9B72F880E6@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv12613 Modified Files: los0.lisp Log Message: *** empty log message *** Date: Tue Jan 4 21:24:00 2005 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.35 movitz/losp/los0.lisp:1.36 --- movitz/losp/los0.lisp:1.35 Wed Dec 15 14:58:26 2004 +++ movitz/losp/los0.lisp Tue Jan 4 21:24:00 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2000-2004, +;;;; Copyright (C) 2000-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: los0.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.35 2004/12/15 13:58:26 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.36 2005/01/04 20:24:00 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -108,6 +108,38 @@ ;;; (declare (dynamic-extent args)) ;;; (apply (constantly 'test-value) args)) +(defun test-closure (x z) + (flet ((closure (y) (= x (1+ y)))) + (declare (dynamic-extent (function closure))) + (closure z) + #+ignore (funcall (lambda (y) (= x (1+ y))) + z))) + +(defun test-stack-cons (x y) + (muerte::with-dynamic-extent-scope (zap) + (let ((foo (muerte::with-dynamic-extent-allocation (zap) + (cons x (lambda () y))))) + (format t "~Z: ~S, ~S" foo foo (funcall (cdr foo)))))) + +(defun test-handler (x) + (let ((foo x)) + (handler-bind + ((error (lambda (c) + (format t "error: ~S ~S" c x)))) + (error "This is an error. ~S" foo)))) + +(defun fooo (v w) + (tagbody + (print (block blurgh + (progv (list v) (list w) + (format t "Uh: ~S" (symbol-value v)) + (if (symbol-value v) + (return-from blurgh 1) + (go zap))))) + zap) + t) + + (defun test-break () (with-inline-assembly (:returns :multiple-values) (:movl 10 :ecx) @@ -544,14 +576,6 @@ (defun test-fixed (x y z) (warn "x: ~W, y: ~W, z: ~W" x y z)) -(defun test-closure (x) - (warn "lending x: ~W" x) - (values (lambda () - (warn "borrowed x: ~W" x) - (* x 2)) - (lambda (y) - (setq x y)))) - (defun test-let-closure () (tagbody (let ((*print-base* 10) @@ -1089,6 +1113,28 @@ (with-simple-restart (abort "Abort to command level ~D." (1+ *repl-level*)) (read-eval-print)))))) +(defun xwrite (object) + (with-inline-assembly (:returns :nothing) + (:locally (:movl (:edi (:edi-offset muerte::dynamic-env)) :eax)) + (:movl :eax (#x1000000)) + (:movl :ebp (#x1000004)) + (:movl :esi (#x1000008))) + (block handler-case-block-1431896 + (let (handler-case-var-1431897) + (tagbody + (handler-bind + ((serious-condition + (lambda (handler-case-temp-var-1431898) + (setq handler-case-var-1431897 handler-case-temp-var-1431898) + (go handler-case-clause-tag-1431899)))) + (return-from handler-case-block-1431896 + (muerte::internal-write object))) + handler-case-clause-tag-1431899 + (return-from handler-case-block-1431896 + (let ((c handler-case-var-1431897)) + (print-unreadable-object (c *standard-output* :type t :identity t) + (format t " while printing ~z" object)))))))) + (defun ub (x) `(hello world ,x or . what)) @@ -1185,7 +1231,7 @@ ;;; (vector-push funobj ts) ;;; (vector-push offset ts) ;;; (vector-push code-vector ts)))) - ;; (muerte::cli) + (muerte::cli) (pic8259-end-of-interrupt 0) (when (eql #\esc (muerte.x86-pc.keyboard:poll-char)) (break "Test-timer keyboard break.")) @@ -1219,8 +1265,7 @@ *timer-stack* (muerte::copy-current-control-stack)) (setf (pit8253-timer-mode 0) +pit8253-mode-single-timeout+ (pit8253-timer-count 0) (or timeout (+ base (random variation)))) - - #+ignore (muerte::sti))) + (muerte::sti))) (with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :ecx) muerte.x86-pc::*screen*) (:shrl 2 :ecx) @@ -1259,7 +1304,7 @@ (progn ;;; (unless (logbitp 9 (eflags)) ;;; (break "Someone switched off interrupts!")) - (incf (memref-int muerte.x86-pc::*screen* :type :unsigned-byte16)) +;;; (incf (memref-int muerte.x86-pc::*screen* :type :unsigned-byte16)) (throw 'foo 'inner-peace)) (incf (memref-int muerte.x86-pc::*screen* :index 80 :type :unsigned-byte16))))) (incf (memref-int muerte.x86-pc::*screen* :index 160 :type :unsigned-byte16)))))) @@ -1305,8 +1350,8 @@ (format t "Extended memory: ~D KB~%" extended-memsize) (idt-init) - #+ignore (install-los0-consing :kb-size 500) + #+ignore (install-los0-consing :kb-size (max 100 (truncate (- extended-memsize 2048) 2)))) (setf *debugger-function* #'los0-debugger) From ffjeld at common-lisp.net Tue Jan 4 20:33:21 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 4 Jan 2005 21:33:21 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/doc/ChangeLog Message-ID: <20050104203321.6D303880E6@common-lisp.net> Update of /project/movitz/cvsroot/movitz/doc In directory common-lisp.net:/tmp/cvs-serv13336 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Tue Jan 4 21:33:17 2005 Author: ffjeld Index: movitz/doc/ChangeLog diff -u movitz/doc/ChangeLog:1.8 movitz/doc/ChangeLog:1.9 --- movitz/doc/ChangeLog:1.8 Tue Jul 20 11:17:38 2004 +++ movitz/doc/ChangeLog Tue Jan 4 21:33:17 2005 @@ -1,3 +1,10 @@ +2005-01-04 Frode Vatvedt Fjeld + + * Fixed some support for stack-allocating funobjs and cons-cells + of dynamic extent. + + * New years resolution: Update this ChangeLog more often. + 2004-07-19 Frode Vatvedt Fjeld * Bignums are now working to the extent that one can basically From ffjeld at common-lisp.net Mon Jan 10 08:18:51 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 10 Jan 2005 09:18:51 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050110081851.43F6F884A5@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26009 Modified Files: compiler.lisp Log Message: Use copy-funobj-code-vector-slots to initialize stack-allocated funobjs. Date: Mon Jan 10 09:18:49 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.127 movitz/compiler.lisp:1.128 --- movitz/compiler.lisp:1.127 Tue Jan 4 21:21:11 2005 +++ movitz/compiler.lisp Mon Jan 10 09:18:49 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.127 2005/01/04 20:21:11 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.128 2005/01/10 08:18:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -84,6 +84,10 @@ (defvar *compiler-produce-defensive-code* t "Try to make code be extra cautious.") +(defvar *compiler-relink-recursive-funcall* t + "If true, also recursive function calls look up the function through the function name, +which enables tracing of recursive functions.") + (defvar *compiler-trust-user-type-declarations-p* t) (defvar *compiling-function-name* nil) @@ -5409,8 +5413,9 @@ :functional-p nil :modifies arguments-modifies :code (append arguments-code - (if (eq (movitz-read operator) - (movitz-read (movitz-funobj-name funobj))) ; recursive? + (if (and (not *compiler-relink-recursive-funcall*) + (eq (movitz-read operator) + (movitz-read (movitz-funobj-name funobj)))) ; recursive? (make-compiled-funcall-by-esi (length arg-forms)) (make-compiled-funcall-by-symbol operator (length arg-forms) funobj)) stack-restore-code)))))) @@ -6908,22 +6913,21 @@ collect `(:pushl (:eax ,(slot-offset 'movitz-funobj 'constant0) ,(* 4 i)))) (loop repeat (movitz-funobj-num-jumpers object) - do (error "Can't handle jumpers.") collect `(:pushl 0)) `((:pushl (:eax ,(slot-offset 'movitz-funobj 'num-jumpers))) (:pushl (:eax ,(slot-offset 'movitz-funobj 'name))) (:pushl (:eax ,(slot-offset 'movitz-funobj 'lambda-list))) -;;; (:pushl 0) ; %3op -;;; (:pushl 0) ; %2op -;;; (:pushl 0) ; %1op -;;; (:pushl 0) ; (default) - (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector%3op))) - (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector%2op))) - (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector%1op))) - (:pushl (:eax ,(slot-offset 'movitz-funobj 'code-vector))) + (:pushl 0) ; %3op + (:pushl 0) ; %2op + (:pushl 0) ; %1op + (:pushl 0) ; (default) - (:pushl (:eax ,(slot-offset 'movitz-funobj 'type)))))))))))) + (:pushl (:eax ,(slot-offset 'movitz-funobj 'type))) + (:leal (:esp ,(tag :other)) :ebx) + (,*compiler-local-segment-prefix* + :call (:edi ,(global-constant-offset 'copy-funobj-code-vector-slots))) + ))))))))) ;;;(define-extended-code-expander :exit-dynamic-scope (instruction funobj frame-map) ;;; nil) From ffjeld at common-lisp.net Mon Jan 10 08:19:04 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 10 Jan 2005 09:19:04 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: <20050110081904.11AC9884A5@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26028 Modified Files: image.lisp Log Message: Use copy-funobj-code-vector-slots to initialize stack-allocated funobjs. Date: Mon Jan 10 09:18:59 2005 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.87 movitz/image.lisp:1.88 --- movitz/image.lisp:1.87 Tue Jan 4 17:53:53 2005 +++ movitz/image.lisp Mon Jan 10 09:18:56 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.87 2005/01/04 16:53:53 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.88 2005/01/10 08:18:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -482,6 +482,11 @@ :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) (dynamic-jump-next + :binary-type code-vector-word + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (copy-funobj-code-vector-slots :binary-type code-vector-word :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector From ffjeld at common-lisp.net Mon Jan 10 08:19:15 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 10 Jan 2005 09:19:15 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: <20050110081915.91CD7884BD@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv26054 Modified Files: primitive-functions.lisp Log Message: Use copy-funobj-code-vector-slots to initialize stack-allocated funobjs. Date: Mon Jan 10 09:19:08 2005 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.59 movitz/losp/muerte/primitive-functions.lisp:1.60 --- movitz/losp/muerte/primitive-functions.lisp:1.59 Tue Jan 4 17:54:20 2005 +++ movitz/losp/muerte/primitive-functions.lisp Mon Jan 10 09:19:06 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.59 2005/01/04 16:54:20 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.60 2005/01/10 08:19:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -692,3 +692,34 @@ (:movl (:edx -4) :esi) ; get target funobj into ESI (:movl (:esp 8) :edx) ; target jumper number (:jmp (:esi :edx (:offset movitz-funobj constant0))))) + +(define-primitive-function copy-funobj-code-vector-slots () + "Copy the (unsafe) code-vector and jumper slots of the funobj in EAX to that in EBX." + ;; Set up thread-atomical execution + (with-inline-assembly (:returns :eax) + (:locally (:movl #.(movitz::atomically-continuation-simple-pf 'copy-funobj-code-vector-slots) + (:edi (:edi-offset atomically-continuation)))) + (:movl (:eax (:offset movitz-funobj code-vector)) :ecx) + (:movl :ecx (:ebx (:offset movitz-funobj code-vector))) + + (:movl (:eax (:offset movitz-funobj code-vector%1op)) :ecx) + (:movl :ecx (:ebx (:offset movitz-funobj code-vector%1op))) + + (:movl (:eax (:offset movitz-funobj code-vector%2op)) :ecx) + (:movl :ecx (:ebx (:offset movitz-funobj code-vector%2op))) + + (:movl (:eax (:offset movitz-funobj code-vector%3op)) :ecx) + (:movl :ecx (:ebx (:offset movitz-funobj code-vector%3op))) + + (:movl (:eax (:offset movitz-funobj num-jumpers)) :edx) + (:andl #xffff :edx) + (:jnz 'copy-jumpers) + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) + (:ret) + copy-jumpers + (:movl (:eax :edx (:offset movitz-funobj constant0 -4)) :ecx) + (:movl :ecx (:ebx :edx (:offset movitz-funobj constant0 -4))) + (:subl 4 :edx) + (:jnz 'copy-jumpers) + (:locally (:movl 0 (:edi (:edi-offset atomically-continuation)))) + (:ret))) From ffjeld at common-lisp.net Mon Jan 10 14:04:55 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 10 Jan 2005 15:04:55 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp Message-ID: <20050110140455.1FDBA884A5@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv10749 Modified Files: memref.lisp Log Message: For (setf memref :code-vector) use *compiler-nonlocal-lispval-write-segment-prefix*. Date: Mon Jan 10 15:04:53 2005 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.40 movitz/losp/muerte/memref.lisp:1.41 --- movitz/losp/muerte/memref.lisp:1.40 Tue Dec 21 15:28:02 2004 +++ movitz/losp/muerte/memref.lisp Mon Jan 10 15:04:52 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.40 2004/12/21 14:28:02 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.41 2005/01/10 14:04:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -748,40 +748,45 @@ (:load-lexical (:lexical-binding ,object-var) :ebx) (,prefixes :movl :eax (:ebx :ecx))))))))) (:code-vector - (cond - ((and (movitz:movitz-constantp offset env) - (movitz:movitz-constantp index env)) - `(with-inline-assembly (:returns :eax) - (:compile-two-forms (:eax :ebx) ,value ,object) - (:movl ,movitz:+code-vector-word-offset+ - (:ebx ,(+ (movitz:movitz-eval offset env) - (* 4 (movitz:movitz-eval index env))))) - (:addl :eax (:ebx ,(+ (movitz:movitz-eval offset env) - (* 4 (movitz:movitz-eval index env))))))) - ((movitz:movitz-constantp offset env) - (let ((value-var (gensym "memref-value-"))) - `(let ((,value-var ,value)) - (with-inline-assembly (:returns :eax) - (:compile-two-forms (:ebx :ecx) ,object ,index) - (:load-lexical (:lexical-binding ,value-var) :eax) - ,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2)) - `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx)) - (:movl ,movitz:+code-vector-word-offset+ - (:ebx :ecx ,(movitz:movitz-eval offset env))) - (:addl :eax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) - (t (error "variable (setf memref) type :code-vector not implemented.") - #+ignore - (let ((value-var (gensym "memref-value-")) - (object-var (gensym "memref-object-"))) - `(let ((,value-var ,value) (,object-var ,object)) + (let ((prefixes (if localp + nil + movitz:*compiler-nonlocal-lispval-write-segment-prefix*))) + (cond + ((and (movitz:movitz-constantp offset env) + (movitz:movitz-constantp index env)) + `(with-inline-assembly (:returns :eax) + (:compile-two-forms (:eax :ebx) ,value ,object) + (:movl ,movitz:+code-vector-word-offset+ + (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env))))) + (,prefixes + :addl :eax (:ebx ,(+ (movitz:movitz-eval offset env) + (* 4 (movitz:movitz-eval index env))))))) + ((movitz:movitz-constantp offset env) + (let ((value-var (gensym "memref-value-"))) + `(let ((,value-var ,value)) (with-inline-assembly (:returns :eax) - (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index) + (:compile-two-forms (:ebx :ecx) ,object ,index) (:load-lexical (:lexical-binding ,value-var) :eax) - ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) - `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx)) - (:addl :ebx :ecx) ; index += offset - (:load-lexical (:lexical-binding ,object-var) :ebx) - (:movl :eax (:ebx :ecx)))))))) + ,@(when (plusp (- movitz:+movitz-fixnum-shift+ 2)) + `((:sarl ,(- movitz:+movitz-fixnum-shift+ 2)) :ecx)) + (:movl ,movitz:+code-vector-word-offset+ + (:ebx :ecx ,(movitz:movitz-eval offset env))) + (,prefixes + :addl :eax (:ebx :ecx ,(movitz:movitz-eval offset env))))))) + (t (error "variable (setf memref) type :code-vector not implemented.") + #+ignore + (let ((value-var (gensym "memref-value-")) + (object-var (gensym "memref-object-"))) + `(let ((,value-var ,value) (,object-var ,object)) + (with-inline-assembly (:returns :eax) + (:compile-two-forms (:untagged-fixnum-ecx :ebx) ,offset ,index) + (:load-lexical (:lexical-binding ,value-var) :eax) + ,@(when (cl:plusp (cl:- movitz::+movitz-fixnum-shift+ 2)) + `((:sarl ,(cl:- movitz::+movitz-fixnum-shift+ 2)) :ebx)) + (:addl :ebx :ecx) ; index += offset + (:load-lexical (:lexical-binding ,object-var) :ebx) + (:movl :eax (:ebx :ecx))))))))) (t ;; (warn "Can't handle inline MEMREF: ~S" form) form)))) From ffjeld at common-lisp.net Mon Jan 17 10:51:12 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 17 Jan 2005 11:51:12 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: <20050117105112.367AD884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30097 Modified Files: interrupt.lisp Log Message: Save the CR2 register in the DIT-frame. It holds the offending address in case of a page-fault. Date: Mon Jan 17 11:51:09 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.34 movitz/losp/muerte/interrupt.lisp:1.35 --- movitz/losp/muerte/interrupt.lisp:1.34 Tue Jan 4 17:54:16 2005 +++ movitz/losp/muerte/interrupt.lisp Mon Jan 17 11:51:09 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.34 2005/01/04 16:54:16 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.35 2005/01/17 10:51:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -27,8 +27,10 @@ :edi :dynamic-env :atomically-continuation - :raw-scratch0 - :ecx :eax :edx :ebx :esi + :raw-scratch0 + :ecx + :cr2 + :eax :edx :ebx :esi :scratch1 :scratch2 :debug0 :debug1 @@ -124,7 +126,10 @@ (:locally (:pushl (:edi (:edi-offset dynamic-env)))) (:locally (:pushl (:edi (:edi-offset atomically-continuation)))) (:locally (:pushl (:edi (:edi-offset raw-scratch0)))) - ,@(loop for reg in (sort (copy-list '(:eax :ebx :ecx :edx :esi)) + (:locally (:pushl :ecx)) + (:movcr :cr2 :ecx) + (:locally (:pushl :ecx)) + ,@(loop for reg in (sort (copy-list '(:eax :ebx :edx :esi)) #'> :key #'dit-frame-index) collect `(:pushl ,reg)) From ffjeld at common-lisp.net Mon Jan 17 10:54:23 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 17 Jan 2005 11:54:23 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: <20050117105423.54241884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30135 Modified Files: storage-types.lisp Log Message: *** empty log message *** Date: Mon Jan 17 11:54:22 2005 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.48 movitz/storage-types.lisp:1.49 --- movitz/storage-types.lisp:1.48 Mon Jan 3 12:55:57 2005 +++ movitz/storage-types.lisp Mon Jan 17 11:54:21 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.48 2005/01/03 11:55:57 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.49 2005/01/17 10:54:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -771,7 +771,10 @@ (entry-protocol :initform :default :initarg :entry-protocol - :reader funobj-entry-protocol)) + :reader funobj-entry-protocol) + (headers-on-stack-frame-p + :initform nil + :accessor headers-on-stack-frame-p)) (:slot-align type #.+other-type-offset+)) (defmethod write-binary-record ((obj movitz-funobj) stream) From ffjeld at common-lisp.net Mon Jan 17 10:54:39 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 17 Jan 2005 11:54:39 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp Message-ID: <20050117105439.D3DDA884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30160 Modified Files: print.lisp Log Message: Minor edit. Date: Mon Jan 17 11:54:38 2005 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.15 movitz/losp/muerte/print.lisp:1.16 --- movitz/losp/muerte/print.lisp:1.15 Mon Oct 11 15:53:09 2004 +++ movitz/losp/muerte/print.lisp Mon Jan 17 11:54:38 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.15 2004/10/11 13:53:09 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.16 2005/01/17 10:54:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -32,6 +32,7 @@ (defvar *print-level* 3) (defvar *print-pretty* t) (defvar *print-circle* nil) +(defvar *print-case* :upcase) (defvar *print-safely* nil) @@ -252,15 +253,13 @@ (let ((name (symbol-name symbol))) (if (and (plusp (length name)) (every (lambda (c) - (or (upper-case-p c) - (member c '(#\+ #\- #\% #\$ #\* #\@ #\. #\& - #\/ #\< #\> #\=)) - (digit-char-p c))) - name) - (not (every (lambda (c) - (or (digit-char-p c *read-base*) - (member c '(#\.)))) - name))) + (and (or (upper-case-p c) + (member c '(#\+ #\- #\% #\$ #\* #\@ #\. #\& + #\/ #\< #\> #\=)) + (digit-char-p c)) + (not (or (digit-char-p c *read-base*) + (member c '(#\.)))))) + name)) (write-string name stream) (stream-write-escaped-string stream name #\|))))) (cond From ffjeld at common-lisp.net Mon Jan 17 11:02:34 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 17 Jan 2005 12:02:34 +0100 (CET) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/print.lisp Message-ID: <20050117110234.2E82F884A9@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv30777 Modified Files: print.lisp Log Message: *** empty log message *** Date: Mon Jan 17 12:02:30 2005 Author: ffjeld Index: movitz/losp/muerte/print.lisp diff -u movitz/losp/muerte/print.lisp:1.16 movitz/losp/muerte/print.lisp:1.17 --- movitz/losp/muerte/print.lisp:1.16 Mon Jan 17 11:54:38 2005 +++ movitz/losp/muerte/print.lisp Mon Jan 17 12:02:27 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Sep 3 11:48:19 2001 ;;;; -;;;; $Id: print.lisp,v 1.16 2005/01/17 10:54:38 ffjeld Exp $ +;;;; $Id: print.lisp,v 1.17 2005/01/17 11:02:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -253,13 +253,15 @@ (let ((name (symbol-name symbol))) (if (and (plusp (length name)) (every (lambda (c) - (and (or (upper-case-p c) - (member c '(#\+ #\- #\% #\$ #\* #\@ #\. #\& - #\/ #\< #\> #\=)) - (digit-char-p c)) - (not (or (digit-char-p c *read-base*) - (member c '(#\.)))))) - name)) + (or (upper-case-p c) + (member c '(#\+ #\- #\% #\$ #\* #\@ #\. #\& + #\/ #\< #\> #\=)) + (digit-char-p c))) + name) + (not (every (lambda (c) + (or (digit-char-p c *read-base*) + (member c '(#\.)))) + name))) (write-string name stream) (stream-write-escaped-string stream name #\|))))) (cond From ffjeld at common-lisp.net Fri Jan 21 21:02:46 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 21 Jan 2005 13:02:46 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: <20050121210246.9FBD288028@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv1838 Modified Files: debugger.lisp Log Message: Added some entries to *stack-frame-setup-patterns* so we avoid some {eax/ebx unknown} in the backtrace. Date: Fri Jan 21 13:02:45 2005 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.28 movitz/losp/x86-pc/debugger.lisp:1.29 --- movitz/losp/x86-pc/debugger.lisp:1.28 Tue Jan 4 08:54:34 2005 +++ movitz/losp/x86-pc/debugger.lisp Fri Jan 21 13:02:45 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.28 2005/01/04 16:54:34 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.29 2005/01/21 21:02:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -310,8 +310,10 @@ (:* 1 (#x55 #x8b #xec #x56)) ; pushl ebp, movl esp (:* 2 (#x80 #xf9 (cmpargs) (:or (#x72 (label)) + (#x75 (label)) (#x77 (label)) (#x0f #x82 (label) (label) (label) (label)) + (#x0f #x85 (label) (label) (label) (label)) (#x0f #x87 (label) (label) (label) (label))))) (:* 1 (#x84 #xc9 ; # (:or (#x78 (label)) ; # From ffjeld at common-lisp.net Fri Jan 21 22:06:09 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 21 Jan 2005 14:06:09 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050121220609.3D20B88028@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4792 Modified Files: compiler.lisp Log Message: Fixed compute-call-extra-prefix whose previous incarnation I _really_ didn't understand (what was I thinking??) Date: Fri Jan 21 14:06:08 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.128 movitz/compiler.lisp:1.129 --- movitz/compiler.lisp:1.128 Mon Jan 10 00:18:49 2005 +++ movitz/compiler.lisp Fri Jan 21 14:06:07 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.128 2005/01/10 08:18:49 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.129 2005/01/21 22:06:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -34,7 +34,7 @@ "Make every compiled function check upon entry that the stack-pointer is within bounds. Costs 3 code-bytes and a few cycles.") -(defvar *compiler-allow-transients* t +(defvar *compiler-allow-transients* nil "Allow the compiler to keep function arguments solely in registers. Hurst debugging, improves performance.") @@ -117,22 +117,19 @@ (+ (ia-x86::assemble-env-current-pc env) size)))) (cond - ((not (and (ia-x86::instruction-operands instr) - (typep (car (ia-x86::instruction-operands instr)) - 'ia-x86::operand-indirect-register) - (eq 'ia-x86::esi - (ia-x86::operand-register (car (ia-x86::instruction-operands instr)))))) + ((not (typep instr 'ia-x86-instr::call)) nil) ((or (= (tag :even-fixnum) return-pointer-tag) (= (tag :odd-fixnum) return-pointer-tag)) ;; Insert a NOP '(#x90)) - ((= 3 return-pointer-tag) - ;; Insert two NOPs, 3 -> 5 - '(#x90 #x90)) +;;; ((= 3 return-pointer-tag) +;;; ;; Insert two NOPs, 3 -> 5 +;;; '(#x90 #x90)) ((= (tag :character) return-pointer-tag) ;; Insert three NOPs, 2 -> 5 - '(#x90 #x90 #x90))))) + '(#x90 #x90 #x90) + '(#x90))))) (defun make-compiled-primitive (form environment top-level-p docstring) "Primitive functions have no funobj, no stack-frame, and no implied @@ -3858,6 +3855,7 @@ (append (make-load-constant sub-funobj register funobj frame-map))) ((typep (movitz-allocation sub-funobj) 'with-dynamic-extent-scope-env) + (setf (headers-on-stack-frame-p funobj) t) (let ((dynamic-scope (movitz-allocation sub-funobj))) (append (make-load-lexical (base-binding dynamic-scope) :edx funobj nil frame-map) From ffjeld at common-lisp.net Tue Jan 25 13:42:40 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 25 Jan 2005 05:42:40 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050125134240.B242F88394@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv15977 Modified Files: compiler.lisp Log Message: Be more observant of *compiler-allow-transients* when locating bindings in registers. Date: Tue Jan 25 05:42:39 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.129 movitz/compiler.lisp:1.130 --- movitz/compiler.lisp:1.129 Fri Jan 21 14:06:07 2005 +++ movitz/compiler.lisp Tue Jan 25 05:42:39 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.129 2005/01/21 22:06:07 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.130 2005/01/25 13:42:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -2841,6 +2841,9 @@ (init-pc (second count-init-pc))) ;; (warn "b ~S: count: ~D, init-pc: ~{~&~A~}" binding count init-pc) (cond + ((and (not *compiler-allow-transients*) + (typep binding 'function-argument)) + (values nil :never)) ((binding-lended-p binding) ;; We can't lend a register. (values nil :never)) From ffjeld at common-lisp.net Tue Jan 25 13:44:12 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 25 Jan 2005 05:44:12 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp Message-ID: <20050125134412.B173988394@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv16003 Modified Files: special-operators-cl.lisp Log Message: Don't do the recompile-body thing. It was an ugly hack. Really. Date: Tue Jan 25 05:44:11 2005 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.42 movitz/special-operators-cl.lisp:1.43 --- movitz/special-operators-cl.lisp:1.42 Tue Jan 4 12:22:00 2005 +++ movitz/special-operators-cl.lisp Tue Jan 25 05:44:11 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.42 2005/01/04 20:22:00 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.43 2005/01/25 13:44:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,8 +56,7 @@ (compiler-call #'compile-implicit-progn :forward all :form body) - (let* ((recompile-body-p nil) - (let-modifies nil) + (let* ((let-modifies nil) (let-vars (parse-let-var-specs let-var-specs)) (local-env (make-local-movitz-environment env funobj :type 'let-env @@ -242,8 +241,6 @@ (binding-name binding) init-form (car (type-specifier-singleton type))) - (when (code-uses-binding-p body-code binding :load t) - (setf recompile-body-p t)) (change-class binding 'constant-object-binding :object (car (type-specifier-singleton type))) (if functional-p @@ -313,10 +310,7 @@ `((:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context 'dynamic-variable-install)))) (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))) - (if (or nil (not recompile-body-p)) - body-code - (progn #+ignore (warn "recompile..") ; XXX - (compile-body))) + body-code (when (and (plusp (num-specials local-env)) (not (eq :non-local-exit body-returns))) #+ignore From ffjeld at common-lisp.net Tue Jan 25 13:45:26 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 25 Jan 2005 05:45:26 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/bignums.lisp Message-ID: <20050125134526.2C66F88394@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16377 Modified Files: bignums.lisp Log Message: *** empty log message *** Date: Tue Jan 25 05:45:25 2005 Author: ffjeld Index: movitz/losp/muerte/bignums.lisp diff -u movitz/losp/muerte/bignums.lisp:1.13 movitz/losp/muerte/bignums.lisp:1.14 --- movitz/losp/muerte/bignums.lisp:1.13 Thu Nov 25 10:05:40 2004 +++ movitz/losp/muerte/bignums.lisp Tue Jan 25 05:45:24 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2003-2004, +;;;; Copyright (C) 2003-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Jul 17 19:42:57 2004 ;;;; -;;;; $Id: bignums.lisp,v 1.13 2004/11/25 18:05:40 ffjeld Exp $ +;;;; $Id: bignums.lisp,v 1.14 2005/01/25 13:45:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ From ffjeld at common-lisp.net Tue Jan 25 13:45:56 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 25 Jan 2005 05:45:56 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/environment.lisp Message-ID: <20050125134556.CCEB58864A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16703 Modified Files: environment.lisp Log Message: fixed some typos in match-caller. Date: Tue Jan 25 05:45:55 2005 Author: ffjeld Index: movitz/losp/muerte/environment.lisp diff -u movitz/losp/muerte/environment.lisp:1.8 movitz/losp/muerte/environment.lisp:1.9 --- movitz/losp/muerte/environment.lisp:1.8 Fri Jul 16 18:54:55 2004 +++ movitz/losp/muerte/environment.lisp Tue Jan 25 05:45:54 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Oct 20 00:41:57 2001 ;;;; -;;;; $Id: environment.lisp,v 1.8 2004/07/17 01:54:55 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.9 2005/01/25 13:45:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -52,10 +52,10 @@ (get-global-property :setf-namespace))))) (defun match-caller (name) - (do ((frame (stack-frame-uplink (current-stack-frame)) - (stack-frame-uplink frame))) + (do ((frame (stack-frame-uplink nil (current-stack-frame)) + (stack-frame-uplink nil frame))) ((not (plusp frame))) - (let ((f (stack-frame-funobj frame))) + (let ((f (stack-frame-funobj nil frame))) (cond ((not (typep f 'function)) (return nil)) From ffjeld at common-lisp.net Tue Jan 25 13:46:11 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 25 Jan 2005 05:46:11 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/format.lisp Message-ID: <20050125134611.B80108864A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16748 Modified Files: format.lisp Log Message: *** empty log message *** Date: Tue Jan 25 05:46:11 2005 Author: ffjeld Index: movitz/losp/muerte/format.lisp diff -u movitz/losp/muerte/format.lisp:1.9 movitz/losp/muerte/format.lisp:1.10 --- movitz/losp/muerte/format.lisp:1.9 Sun Nov 7 13:10:03 2004 +++ movitz/losp/muerte/format.lisp Tue Jan 25 05:46:10 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Mar 23 01:18:36 2002 ;;;; -;;;; $Id: format.lisp,v 1.9 2004/11/07 21:10:03 ffjeld Exp $ +;;;; $Id: format.lisp,v 1.10 2005/01/25 13:46:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -127,11 +127,12 @@ (i start)) (tagbody loop - (unless (< i (length control-string)) + (when (>= i (length control-string)) (go end-loop)) (let ((c (schar control-string i))) (if (char/= c #\~) (write-char c) + ;; Process ~ directive (prog ((colon-p nil) (at-sign-p nil) (prefix-parameters nil)) @@ -289,6 +290,14 @@ (third prefix-parameters)) (go end-loop))) (t (error "format directive ~^ takes at most 3 parameters.")))) + #+ignore + (#\( (multiple-value-setq (i args) + (format-by-string control-string (1+ i) loop-limit args + (cond + ((and colon-p at-sign-p) :upcase) + (colon-p :capitalize) + (at-sign-p :capitalize-first) + (t :downcase))))) (#\? (format-by-string (pop args) 0 0 (pop args))) (#\: (setf colon-p t) (go proceed)) From ffjeld at common-lisp.net Tue Jan 25 13:46:55 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 25 Jan 2005 05:46:55 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/functions.lisp Message-ID: <20050125134655.43FFD8864A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16766 Modified Files: functions.lisp Log Message: Renamed funobj-frame-raw-locals. Added funobj-frame-headers-p. Date: Tue Jan 25 05:46:54 2005 Author: ffjeld Index: movitz/losp/muerte/functions.lisp diff -u movitz/losp/muerte/functions.lisp:1.25 movitz/losp/muerte/functions.lisp:1.26 --- movitz/losp/muerte/functions.lisp:1.25 Tue Dec 14 08:20:57 2004 +++ movitz/losp/muerte/functions.lisp Tue Jan 25 05:46:54 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 12 22:58:54 2002 ;;;; -;;;; $Id: functions.lisp,v 1.25 2004/12/14 16:20:57 ffjeld Exp $ +;;;; $Id: functions.lisp,v 1.26 2005/01/25 13:46:54 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -388,10 +388,15 @@ (check-type funobj function) (memref funobj (movitz-type-slot-offset 'movitz-funobj 'debug-info) :type :unsigned-byte16)) -(defun funobj-frame-num-unboxed (funobj) +(defun funobj-frame-raw-locals (funobj) "The number of unboxed slots in this function's stack-frame(s)." (declare (ignore funobj)) 0) + +(defun funobj-frame-headers-p (funobj) + "Can this function place header-vals in its stack-frame?" + (declare (ignore funobj)) + t) (defun make-funobj (&key (name :unnamed) (code-vector (funobj-code-vector #'constantly-prototype)) From ffjeld at common-lisp.net Tue Jan 25 13:49:52 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 25 Jan 2005 05:49:52 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/inspect.lisp Message-ID: <20050125134952.D04BF8864A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16792 Modified Files: inspect.lisp Log Message: Fixed %find-code-vector. Date: Tue Jan 25 05:49:51 2005 Author: ffjeld Index: movitz/losp/muerte/inspect.lisp diff -u movitz/losp/muerte/inspect.lisp:1.45 movitz/losp/muerte/inspect.lisp:1.46 --- movitz/losp/muerte/inspect.lisp:1.45 Tue Dec 21 06:27:09 2004 +++ movitz/losp/muerte/inspect.lisp Tue Jan 25 05:49:51 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001, 2003-2004, +;;;; Copyright (C) 2001, 2003-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Oct 24 09:50:41 2003 ;;;; -;;;; $Id: inspect.lisp,v 1.45 2004/12/21 14:27:09 ffjeld Exp $ +;;;; $Id: inspect.lisp,v 1.46 2005/01/25 13:49:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -41,11 +41,21 @@ (defun stack-frame-funobj (stack frame) (stack-frame-ref stack frame -1)) +(defun stack-location (stack index) + (if (eq nil stack) + index + (+ (object-location stack) 2 index))) + (defun stack-frame-uplink (stack frame) (if (eq 0 (stack-frame-funobj stack frame)) (dit-frame-casf stack frame) (stack-frame-ref stack frame 0))) +(defun stack-vector-designator (stack) + (etypecase stack + (null (%run-time-context-slot 'stack-vector)) + (vector stack))) + (define-compiler-macro current-stack-frame () `(with-inline-assembly (:returns :eax) (:leal ((:ebp ,(truncate movitz::+movitz-fixnum-factor+ 4))) @@ -176,23 +186,21 @@ (do ((l (logand location -2) (- l 2))) ((< l stop-location) (error "Unable to find code-vector for location ~S." location)) - (multiple-value-bind (upper30 lower2) - (memref l 0 :type :signed-byte30+2) - (when (and (= 2 lower2) - (= #.(movitz:basic-vector-type-tag :code)) - ;; If the vector has a fill-pointer, it should be equal to the length. - (multiple-value-bind (len len-tag) - (memref l 4 :type :signed-byte30+2) - (and (= 0 len-tag) - (typecase len - ((integer 0 #x3fff) - (= len (memref l 2 :type :unsigned-byte14))) - (positive-fixnum t) - (t nil))))) - (let ((code-vector (%location-object l 6))) - (check-type code-vector code-vector) - (assert (location-in-object-p code-vector location)) - (return code-vector)))))) + (when (and (= (memref l 0 :type :unsigned-byte16) + #.(movitz:basic-vector-type-tag :code)) + ;; If the vector has a fill-pointer, it should be equal to the length. + (multiple-value-bind (len len-tag) + (memref l 4 :type :signed-byte30+2) + (and (= 0 len-tag) + (typecase len + ((integer 0 #x3fff) + (= len (memref l 2 :type :unsigned-byte14))) + (positive-fixnum t) + (t nil))))) + (let ((code-vector (%location-object l 6))) + (check-type code-vector code-vector) + (assert (location-in-object-p code-vector location)) + (return code-vector))))) (defun %shallow-copy-object (object word-count) "Copy any object with size word-count." From ffjeld at common-lisp.net Tue Jan 25 13:50:18 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 25 Jan 2005 05:50:18 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: <20050125135018.82C718864A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16828 Modified Files: interrupt.lisp Log Message: Minor tweaks in the DIT. Date: Tue Jan 25 05:50:17 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.35 movitz/losp/muerte/interrupt.lisp:1.36 --- movitz/losp/muerte/interrupt.lisp:1.35 Mon Jan 17 02:51:09 2005 +++ movitz/losp/muerte/interrupt.lisp Tue Jan 25 05:50:16 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.35 2005/01/17 10:51:09 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.36 2005/01/25 13:50:16 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -21,6 +21,7 @@ (defvar *last-dit-frame* nil) (defconstant +dit-frame-map+ + ;; Do NOT rearrange this randomly. '(:eflags :cs :eip :error-code :exception-vector :ebp :funobj @@ -275,8 +276,9 @@ (:int 63))) (:cmpw ,(movitz:basic-vector-type-tag :code) (:eax ,movitz:+other-type-offset+)) (:jne 'pf-continuation-not-code-vector) - (:leal (:eax ,movitz:+code-vector-word-offset+) :ecx) - (:movl :ecx (:ebp ,(dit-frame-offset :eip))) + (:movl ,movitz:+code-vector-word-offset+ (:ebp ,(dit-frame-offset :eip))) + (:addl :eax (:ebp ,(dit-frame-offset :eip))) + (:jmp 'normal-return) not-restart-continuation From ffjeld at common-lisp.net Tue Jan 25 13:51:39 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 25 Jan 2005 05:51:39 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/memref.lisp Message-ID: <20050125135139.C8D118864A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16914 Modified Files: memref.lisp Log Message: *** empty log message *** Date: Tue Jan 25 05:51:36 2005 Author: ffjeld Index: movitz/losp/muerte/memref.lisp diff -u movitz/losp/muerte/memref.lisp:1.41 movitz/losp/muerte/memref.lisp:1.42 --- movitz/losp/muerte/memref.lisp:1.41 Mon Jan 10 06:04:52 2005 +++ movitz/losp/muerte/memref.lisp Tue Jan 25 05:51:36 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Mar 6 21:25:49 2001 ;;;; -;;;; $Id: memref.lisp,v 1.41 2005/01/10 14:04:52 ffjeld Exp $ +;;;; $Id: memref.lisp,v 1.42 2005/01/25 13:51:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -224,7 +224,7 @@ , at fix-ecx)) (t (let ((object-var (gensym "memref-object-"))) `(let ((,object-var ,object)) - (with-inline-assembly (:returns :ecx :type (unsigned-byte 29)) + (with-inline-assembly (:returns :multiple-values) (:compile-two-forms (:ecx :ebx) ,offset ,index) (:sarl ,movitz::+movitz-fixnum-shift+ :ecx) (:load-lexical (:lexical-binding ,object-var) :eax) @@ -411,9 +411,9 @@ ((:big) (memref object offset :index index :type :unsigned-byte16 :endian :big)))) (:code-vector (memref object offset :index index :type :code-vector)) - (:unsigned-byte14 (memref object offset :index index :type :unsigned-byte14)))) -;;; (:signed-byte30+2 (memref object offset index :signed-byte30+2)) -;;; (:unsigned-byte29+3 (memref object offset index :unsigned-byte29+3)))) + (:unsigned-byte14 (memref object offset :index index :type :unsigned-byte14)) + (:signed-byte30+2 (memref object offset :index index :type :signed-byte30+2)) + (:unsigned-byte29+3 (memref object offset :index index :type :unsigned-byte29+3)))) (define-compiler-macro (setf memref) (&whole form &environment env value object offset &key (index 0) (type :lisp) (localp nil) (endian :host)) @@ -963,7 +963,7 @@ (:movl :ecx (:eax ,offset))))))) (:lisp (assert (= 4 movitz:+movitz-fixnum-factor+)) - `(with-inline-assembly (:returns :untagged-fixnum-eax) + `(with-inline-assembly (:returns :eax) (:compile-form (:result-mode :push) ,address) (:compile-form (:result-mode :push) ,index) (:compile-form (:result-mode :push) ,offset) @@ -975,7 +975,7 @@ (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) (,prefixes :movl :eax (:ecx :ebx)))) (:unsigned-byte8 - `(with-inline-assembly (:returns :untagged-fixnum-eax) + `(with-inline-assembly (:returns :nothing) (:compile-form (:result-mode :push) ,address) (:compile-form (:result-mode :push) ,index) (:compile-form (:result-mode :push) ,offset) @@ -983,11 +983,11 @@ (:popl :edx) ; offset (:popl :ebx) ; index (:popl :ecx) ; address - (:shrl ,movitz::+movitz-fixnum-shift+ :eax) + (:shll ,(- 8 movitz::+movitz-fixnum-shift+) :eax) (:addl :ebx :ecx) (:addl :edx :ecx) (:shrl ,movitz::+movitz-fixnum-shift+ :ecx) - (,prefixes :movb :al (:ecx)))) + (,prefixes :movb :ah (:ecx)))) (:unsigned-byte16 (cond ((eq 0 offset) From ffjeld at common-lisp.net Tue Jan 25 13:52:27 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 25 Jan 2005 05:52:27 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette.lisp Message-ID: <20050125135227.4D8018864A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv16960 Modified Files: los-closette.lisp Log Message: *** empty log message *** Date: Tue Jan 25 05:52:26 2005 Author: ffjeld Index: movitz/losp/muerte/los-closette.lisp diff -u movitz/losp/muerte/los-closette.lisp:1.25 movitz/losp/muerte/los-closette.lisp:1.26 --- movitz/losp/muerte/los-closette.lisp:1.25 Tue Jan 4 12:23:16 2005 +++ movitz/losp/muerte/los-closette.lisp Tue Jan 25 05:52:25 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Jul 23 14:29:10 2002 ;;;; -;;;; $Id: los-closette.lisp,v 1.25 2005/01/04 20:23:16 ffjeld Exp $ +;;;; $Id: los-closette.lisp,v 1.26 2005/01/25 13:52:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1004,6 +1004,7 @@ (defclass illegal-object (t) () (:metaclass built-in-class)) (defclass infant-object (t) () (:metaclass built-in-class)) +(defclass unbound-value (t) () (:metaclass built-in-class)) (defclass run-time-context (t) () From ffjeld at common-lisp.net Tue Jan 25 13:55:00 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 25 Jan 2005 05:55:00 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: <20050125135500.E1CCD8864A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17058 Modified Files: primitive-functions.lisp Log Message: Minor edit. Date: Tue Jan 25 05:54:57 2005 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.60 movitz/losp/muerte/primitive-functions.lisp:1.61 --- movitz/losp/muerte/primitive-functions.lisp:1.60 Mon Jan 10 00:19:06 2005 +++ movitz/losp/muerte/primitive-functions.lisp Tue Jan 25 05:54:57 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.60 2005/01/10 08:19:06 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.61 2005/01/25 13:54:57 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -482,11 +482,10 @@ (:movl (:eax #.(movitz::class-object-offset 'symbol)) :eax) (:ret))) - (define-primitive-function fast-class-of-std-instance () "Return the class of a std-instance object." (with-inline-assembly (:returns :multiple-values) - (:movl (:eax #.(bt:slot-offset 'movitz::movitz-std-instance 'movitz::class)) + (:movl (:eax (:offset movitz-std-instance class)) :eax) (:ret))) From ffjeld at common-lisp.net Tue Jan 25 13:55:37 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 25 Jan 2005 05:55:37 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/typep.lisp Message-ID: <20050125135537.30E488864A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17128 Modified Files: typep.lisp Log Message: Added (typep x 'unbound-value). Date: Tue Jan 25 05:55:36 2005 Author: ffjeld Index: movitz/losp/muerte/typep.lisp diff -u movitz/losp/muerte/typep.lisp:1.40 movitz/losp/muerte/typep.lisp:1.41 --- movitz/losp/muerte/typep.lisp:1.40 Mon Dec 13 03:25:41 2004 +++ movitz/losp/muerte/typep.lisp Tue Jan 25 05:55:36 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2000-2004, +;;;; Copyright (C) 2000-2005, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: typep.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 8 11:07:53 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: typep.lisp,v 1.40 2004/12/13 11:25:41 ffjeld Exp $ +;;;; $Id: typep.lisp,v 1.41 2005/01/25 13:55:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -261,6 +261,10 @@ (make-basic-vector-typep :u32)) (code-vector (make-basic-vector-typep :code)) + (unbound-value + `(with-inline-assembly (:returns :boolean-overflow) + (:compile-form (:result-mode :eax) ,object) + (:cmpl -1 :eax))) (run-time-context (make-other-typep :run-time-context)) (structure-object From ffjeld at common-lisp.net Tue Jan 25 13:56:15 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 25 Jan 2005 05:56:15 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: <20050125135615.627EB8864A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv17162 Modified Files: los0-gc.lisp Log Message: Re-working the stack discipline/scavenging strategy. Still not quite there, but it seems close. Date: Tue Jan 25 05:56:14 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.45 movitz/losp/los0-gc.lisp:1.46 --- movitz/losp/los0-gc.lisp:1.45 Wed Dec 8 15:39:51 2004 +++ movitz/losp/los0-gc.lisp Tue Jan 25 05:56:14 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2003-2004, +;;;; Copyright (C) 2003-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.45 2004/12/08 23:39:51 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.46 2005/01/25 13:56:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -109,6 +109,7 @@ (macrolet ((do-it () `(with-inline-assembly (:returns :nothing) + retry (:compile-form (:result-mode :eax) (+ free-space trigger)) (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) (:testl ,(logxor #xffffffff @@ -121,6 +122,11 @@ :ecx) (:subl :eax :ecx) (:movl (:edx 2) :ebx) + (:cmpl :ecx :ebx) + (:jc '(:sub-program () + ;; Current newspace was too full, so trigger a GC. + (:int 113) + (:jmp 'retry))) (:movl :ecx (:edx 2)) (:addl 8 :ebx) fill-loop @@ -138,7 +144,6 @@ (macrolet ((do-it () `(with-inline-assembly (:returns :multiple-values) - retry (:locally (:cmpl 0 (:edi (:edi-offset atomically-continuation)))) ; Atomically? (:je '(:sub-program () (:int 63))) ; This must be called inside atomically. @@ -151,8 +156,8 @@ (:ja '(:sub-program (probe-failed) (:int 113) (:int 63))) - (:leal (:edx :ebx 8) :eax) (:movl :edi (:edx :ebx 8 ,movitz:+other-type-offset+)) + (:leal (:edx :ebx 8) :eax) (:ret)))) (do-it))) @@ -162,7 +167,6 @@ (macrolet ((do-it () `(with-inline-assembly (:returns :multiple-values) - retry (:locally (:cmpl 0 (:edi (:edi-offset atomically-continuation)))) ; Atomically? (:je '(:sub-program () (:int 63))) ; This must be called inside atomically. @@ -174,7 +178,7 @@ :ecx) (:ja '(:sub-program (commit-failed) (:int 113) - (:jmp 'retry))) + (:int 63))) (:movl :ecx (:edx 2)) (:leal (:edx :ecx) :ecx) (:ret)))) @@ -190,7 +194,6 @@ (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)) :eax) (:ret) not-fixnum - retry-cons (:locally (:movl ,(movitz::atomically-continuation-simple-pf 'box-u32-ecx) (:edi (:edi-offset atomically-continuation)))) (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) @@ -211,7 +214,8 @@ (:ret)))) (do-it))) -(defvar *gc-stack*) +(defvar *gc-stack* nil) +(defvar *gc-stack2* nil) (defun install-los0-consing (&key (context (current-run-time-context)) (kb-size 1024) @@ -401,23 +405,37 @@ (break "Seeing old object in values-vector: ~Z" x)) x) #x38 #xb8) - (let* ((stack (%run-time-context-slot 'muerte::nursery-space)) + (let* ((stack (%run-time-context-slot 'muerte::stack-vector)) (stack-start (- (length stack) (muerte::current-control-stack-depth)))) (do ((i 0 (+ i 3))) ((>= i (length a))) - (when (find (aref a i) stack :start stack-start) - (break "Seeing old object ~S in current stack!" - (aref a i)))))))) - + (let* ((offender? (aref a i)) + (offender-index (position offender? stack :start stack-start))) + (when offender-index + (break "Seeing old object ~S in current stack at ~S, new is ~S" + offender? + (+ (object-location stack) + offender-index 2) + (aref a (+ i 2)))))) + (loop for x from 0 to #xa0000 + do (when (= #x19a04e (memref x 0 :type :unsigned-byte32)) + (warn "Seeing foo at ~S." x))) + (loop for i from stack-start below (length stack) + as o = (aref stack i) + do (when (and (typep o 'pointer) + (location-in-object-p oldspace (object-location o))) + (break "Seeing old (unmapped) object ~Z in stack at ~S." + o (+ (object-location stack) i 2)))))))) ;; GC completed, oldspace is evacuated. (unless *gc-quiet* (let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2)) (new-size (truncate (- (space-fresh-pointer newspace) 2) 2))) - (format t "Old space: ~/muerte:pprint-clumps/, new space: ~ + (format t "Old space [~Z]: ~/muerte:pprint-clumps/, new space [~Z]: ~ ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%" - old-size new-size (- old-size new-size)))) + oldspace old-size newspace new-size (- old-size new-size)))) (initialize-space oldspace) (fill oldspace #x13 :start 2) + ;; (setf *gc-stack2* *gc-stack*) (setf *gc-stack* (muerte::copy-current-control-stack)) (setf (fill-pointer *xx*) (fill-pointer *x*)) (replace *xx* *x*))) From ffjeld at common-lisp.net Tue Jan 25 13:56:21 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 25 Jan 2005 05:56:21 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: <20050125135621.B489388651@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv17178 Modified Files: scavenge.lisp Log Message: Re-working the stack discipline/scavenging strategy. Still not quite there, but it seems close. Date: Tue Jan 25 05:56:19 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.39 movitz/losp/muerte/scavenge.lisp:1.40 --- movitz/losp/muerte/scavenge.lisp:1.39 Tue Jan 4 08:54:27 2005 +++ movitz/losp/muerte/scavenge.lisp Tue Jan 25 05:56:18 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.39 2005/01/04 16:54:27 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.40 2005/01/25 13:56:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -36,7 +36,7 @@ (loop for location from start-location below end-location as object = (memref location 0) do (when (typep object 'pointer) - (let ((new-object (do-map object))) + (let ((new-object (do-map object location))) (unless (eq object new-object) (setf (memref location 0) new-object))))))) @@ -139,7 +139,7 @@ #.(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))) - ((eq x 3) + ((and (eq x 3) (eq x2 0)) (setf *scan-last* scan) (incf scan) (let ((delta (memref scan 0))) @@ -147,17 +147,208 @@ ;; (warn "at ~S skipping ~S to ~S." scan delta (+ scan delta)) (incf scan delta))) (t ;; (typep x 'pointer) - (let* ((old (memref scan 0)) - (new (funcall function old scan))) - (when verbose - (format *terminal-io* " [~Z => ~Z]" old new)) - (unless (eq old new) - (setf (memref scan 0) new))))))))) + (let ((old (memref scan 0))) + (unless (eq old (load-global-constant new-unbound-value)) + (let ((new (funcall function old scan))) + (when verbose + (format *terminal-io* " [~Z => ~Z]" old new)) + (unless (eq old new) + (setf (memref scan 0) new))))))))))) (values)) (defun map-stack-vector (function stack start-frame &optional (map-region #'map-header-vals)) "Map function over the potential pointer words of a stack, starting at the start-stack-frame location." + (assert (typep (stack-frame-funobj stack start-frame) 'function) (start-frame) + "Cannot start map-stack-vector at a non-normal frame.") + (assert (eq nil stack)) + (map-stack function + (stack-frame-uplink stack start-frame) + (+ start-frame 2) + (+ start-frame 1) + map-region)) + +;;;(defun map-code-vector-slot (function stack slot casf-funobj) +;;; (let ((casf-code-vector (if (eq 0 casf-funobj) +;;; (symbol-value 'default-interrupt-trampoline) +;;; (funobj-code-vector casf-funobj))) +;;; (eip-location (stack-frame-ref stack slot 0 :location))) +;;; (cond +;;; ((location-in-object-p casf-code-vector eip-location) +;;; (let ((new (funcall function casf-code-vector nil))) +;;; (when (not (eq new casf-code-vector)) +;;; ;; Perform some pointer arithmetics.. +;;; (let ((offset (- (stack-frame-ref stack slot 0 :unsigned-byte32) +;;; (%object-lispval casf-code-vector)))) +;;; (break "Code-vector for ~S moved, offset is ~D." casf-code-vector offset)))))))) + +(defun scavenge-find-code-vector (location casf-funobj esi &optional searchp) + (flet ((match-funobj (funobj location) + (cond + ((let ((x (funobj-code-vector casf-funobj))) + (and (location-in-object-p x location) x))) + ((let ((x (funobj-code-vector%1op casf-funobj))) + (and (typep x 'vector) + (location-in-object-p x location) + x))) + ((let ((x (funobj-code-vector%2op casf-funobj))) + (and (typep x 'vector) + (location-in-object-p x location) + x))) + ((let ((x (funobj-code-vector%3op casf-funobj))) + (and (typep x 'vector) + (location-in-object-p x location) + x)))))) + (cond + ((eq 0 casf-funobj) + (let ((dit-code-vector (symbol-value 'default-interrupt-trampoline))) + (if (location-in-object-p dit-code-vector location) + dit-code-vector + (break "DIT returns outside DIT??")))) + ((and (typep esi 'function) + (match-funobj esi location))) + ((match-funobj casf-funobj location)) + ((not (typep casf-funobj 'function)) + (break "Unknown funobj/frame-type: ~S" casf-funobj)) + ((when searchp + (%find-code-vector location))) + (t (error "Unable to decode EIP #x~X funobj ~S." location casf-funobj))))) + +(defun map-stack-value (function value frame) + (if (not (typep value 'pointer)) + value + (funcall function value frame))) + +(defun map-stack (function frame frame-bottom eip-index map-region) + (with-funcallable (map-region) + (loop + ;; for frame = frame then (stack-frame-uplink frame) + ;; as frame-end = frame-end then frame + while (not (eq 0 frame)) + do (map-lisp-vals function (1- frame) frame) + (let ((frame-funobj (map-stack-value function (stack-frame-funobj nil frame) frame))) + (cond + ((eq 0 frame-funobj) + (return (map-stack-dit function frame frame-bottom eip-index map-region))) + ((not (typep frame-funobj 'function)) + (error "Unknown stack-frame funobj ~S at ~S" frame-funobj frame)) + (t (let* ((old-code-vector + (scavenge-find-code-vector (stack-frame-ref nil eip-index 0 :location) + frame-funobj nil nil))) + (map-stack-instruction-pointer function eip-index old-code-vector)) + (let ((raw-locals (funobj-frame-raw-locals frame-funobj))) + (if (= 0 raw-locals) + (map-region function frame-bottom frame) + (progn + (break "~D raw-locals for ~S?" raw-locals frame-funobj) + (map-region function (1- frame) frame) + (map-region function frame-bottom (- frame 1 raw-locals)))) + (setf eip-index (+ frame 1) + frame-bottom (+ frame 2) + frame (stack-frame-uplink nil frame))))))))) + +(defun test-stack () + (let ((z (current-stack-frame))) + (map-stack (lambda (x y) + (format t "~&[~S]: ~S" y x) + x) + (stack-frame-uplink nil z) (+ z 2) (+ z 1) + #'map-header-vals))) + +(defun map-stack-dit (function dit-frame frame-bottom eip-index map-region) + (with-funcallable (map-region) + (let* ((atomically + (dit-frame-ref nil dit-frame :atomically-continuation :unsigned-byte32)) + (secondary-register-mode-p + (logbitp 10 (dit-frame-ref nil dit-frame :eflags :unsigned-byte32))) + (casf-frame + (dit-frame-casf nil dit-frame)) + (casf-funobj (map-stack-value function (stack-frame-funobj nil casf-frame) casf-frame)) + (casf-code-vector (map-stack-value function + (case casf-funobj + (0 (symbol-value 'default-interrupt-trampoline)) + (t (funobj-code-vector casf-funobj))) + casf-frame))) + ;; 1. Scavenge the dit-frame + (cond + ((and (not (= 0 atomically)) + (= 0 (ldb (byte 2 0) atomically))) + ;; Interrupt occurred inside an (non-pf) atomically, so none of the + ;; GC-root registers are active. + (setf (dit-frame-ref nil dit-frame :eax) nil + (dit-frame-ref nil dit-frame :ebx) nil + (dit-frame-ref nil dit-frame :edx) nil + (dit-frame-ref nil dit-frame :esi) nil) + (map-region function frame-bottom (+ dit-frame 1 (dit-frame-index :scratch1)))) + (secondary-register-mode-p + ;; EBX is also active + (map-region function frame-bottom (+ dit-frame 1 (dit-frame-index :ebx)))) + (t ;; EDX and EAX too. + (map-region function frame-bottom (+ dit-frame 1 (dit-frame-index :eax))))) + ;; The DIT's return-address + (let* ((interrupted-esi (dit-frame-ref nil dit-frame :esi)) + (next-frame-bottom (+ dit-frame 1 (dit-frame-index :eflags))) + (next-eip-index (+ dit-frame (dit-frame-index :eip))) + (old-code-vector + (scavenge-find-code-vector (stack-frame-ref nil eip-index 0 :location) + 0 interrupted-esi + nil)) + (new-code-vector (map-stack-instruction-pointer function eip-index old-code-vector))) + ;; + (multiple-value-bind (x0-location x0-tag) + (stack-frame-ref nil next-frame-bottom 0 :signed-byte30+2) + ;; (warn "X0: ~S ~S" x0-location x0-tag) + (cond + ((and (or (eq x0-tag 1) ; 1 or 5? + (eq x0-tag 3) ; 3 or 7? + (and (oddp x0-location) (eq x0-tag 2))) ; 6? + (location-in-object-p casf-code-vector x0-location)) + (let* ((old-x0-code-vector + (scavenge-find-code-vector (stack-frame-ref nil next-eip-index 0 :location) + casf-funobj interrupted-esi t))) + (map-stack-instruction-pointer function next-eip-index old-x0-code-vector)) + (setf next-eip-index next-frame-bottom + next-frame-bottom (1+ next-frame-bottom))) + (t (multiple-value-bind (x1-location x1-tag) + (stack-frame-ref nil next-frame-bottom 1 :signed-byte30+2) + (when (and (or (eq x1-tag 1) ; 1 or 5? + (eq x1-tag 3) ; 3 or 7? + (and (oddp x1-location) (eq x1-tag 2))) ; 6? + (location-in-object-p casf-code-vector x1-location)) + (warn "X1: ~S ~S" x1-location x1-tag) + (let* ((old-x1-code-vector + (scavenge-find-code-vector (stack-frame-ref nil next-eip-index 0 :location) + casf-funobj interrupted-esi t))) + (map-stack-instruction-pointer function next-eip-index old-x1-code-vector)) + (setf next-eip-index (+ 1 next-frame-bottom) + next-frame-bottom (+ 2 next-frame-bottom))))))) + ;; proceed + (map-stack function casf-frame next-frame-bottom next-eip-index map-region))))) + +(defun map-stack-instruction-pointer (function index old-code-vector) + "Update the (raw) instruction-pointer in stack at index, +assuming the pointer refers to old-code-vector." + (assert (location-in-object-p old-code-vector (stack-frame-ref nil index 0 :location))) + (let ((new-code-vector (funcall function old-code-vector nil))) + (when (not (eq old-code-vector new-code-vector)) + (break "Code-vector for stack instruction-pointer moved. [index: ~S]" index)) + new-code-vector)) + +(defun map-stack-flaccid-pointer (function index) + "If the pointed-to object is moved, reset pointer to NIL." + (let ((old (stack-frame-ref nil index 0))) + (cond + ((not (typep old 'pointer)) + old) + ((eq old (funcall function old index)) + old) + (t (setf (stack-frame-ref nil index 0) nil))))) + + +#+ignore +(defun old-map-stack-vector (function stack start-frame &optional (map-region #'map-header-vals)) + "Map function over the potential pointer words of a stack, starting +at the start-stack-frame location." (with-funcallable (map-region) (loop with next-frame with next-nether-frame for nether-frame = start-frame then (or next-nether-frame frame) @@ -176,7 +367,7 @@ (incf nether-frame 4)) (typecase funobj ((or function null) - (assert (= 0 (funobj-frame-num-unboxed funobj))) + (assert (= 0 (funobj-frame-raw-locals funobj))) (map-region function (+ nether-frame 2) frame)) ((eql 0) ; A dit interrupt-frame? (let* ((dit-frame frame) @@ -210,10 +401,6 @@ (interrupted-ebp (dit-frame-ref stack dit-frame :ebp)) (casf-funobj (funcall function (stack-frame-funobj stack frame) frame))) (cond - #+ignore - ((eq nil casf-funobj) - (warn "Scanning interrupt in PF: ~S" - (dit-frame-ref stack dit-frame :eip :unsigned-byte32))) ((or (eq 0 casf-funobj) (typep casf-funobj 'function)) (let ((casf-code-vector (scavenge-funobj-code-vector casf-funobj))) From ffjeld at common-lisp.net Wed Jan 26 13:46:15 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 26 Jan 2005 05:46:15 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: <20050126134615.1D05B8802D@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv27148 Modified Files: scavenge.lisp Log Message: In scavenge-find-code-vector, fixed the situation when the DIT shared an inclomplete stack-frame with the handler. Date: Wed Jan 26 05:46:14 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.40 movitz/losp/muerte/scavenge.lisp:1.41 --- movitz/losp/muerte/scavenge.lisp:1.40 Tue Jan 25 05:56:18 2005 +++ movitz/losp/muerte/scavenge.lisp Wed Jan 26 05:46:14 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.40 2005/01/25 13:56:18 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.41 2005/01/26 13:46:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -168,23 +168,11 @@ (+ start-frame 1) map-region)) -;;;(defun map-code-vector-slot (function stack slot casf-funobj) -;;; (let ((casf-code-vector (if (eq 0 casf-funobj) -;;; (symbol-value 'default-interrupt-trampoline) -;;; (funobj-code-vector casf-funobj))) -;;; (eip-location (stack-frame-ref stack slot 0 :location))) -;;; (cond -;;; ((location-in-object-p casf-code-vector eip-location) -;;; (let ((new (funcall function casf-code-vector nil))) -;;; (when (not (eq new casf-code-vector)) -;;; ;; Perform some pointer arithmetics.. -;;; (let ((offset (- (stack-frame-ref stack slot 0 :unsigned-byte32) -;;; (%object-lispval casf-code-vector)))) -;;; (break "Code-vector for ~S moved, offset is ~D." casf-code-vector offset)))))))) - (defun scavenge-find-code-vector (location casf-funobj esi &optional searchp) (flet ((match-funobj (funobj location) (cond + ((not (typep funobj 'function)) + nil) ((let ((x (funobj-code-vector casf-funobj))) (and (location-in-object-p x location) x))) ((let ((x (funobj-code-vector%1op casf-funobj))) @@ -202,12 +190,13 @@ (cond ((eq 0 casf-funobj) (let ((dit-code-vector (symbol-value 'default-interrupt-trampoline))) - (if (location-in-object-p dit-code-vector location) - dit-code-vector - (break "DIT returns outside DIT??")))) - ((and (typep esi 'function) - (match-funobj esi location))) + (cond + ((location-in-object-p dit-code-vector location) + dit-code-vector) + ((match-funobj esi)) + (t (break "DIT returns outside DIT??"))))) ((match-funobj casf-funobj location)) + ((match-funobj esi location)) ((not (typep casf-funobj 'function)) (break "Unknown funobj/frame-type: ~S" casf-funobj)) ((when searchp @@ -275,6 +264,7 @@ (= 0 (ldb (byte 2 0) atomically))) ;; Interrupt occurred inside an (non-pf) atomically, so none of the ;; GC-root registers are active. + #+ignore (setf (dit-frame-ref nil dit-frame :eax) nil (dit-frame-ref nil dit-frame :ebx) nil (dit-frame-ref nil dit-frame :edx) nil From ffjeld at common-lisp.net Wed Jan 26 13:49:25 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 26 Jan 2005 05:49:25 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: <20050126134925.5917A8802D@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv27181 Modified Files: los0-gc.lisp Log Message: Debugging tweaks: Don't trigger-newspace when *gc-running*. Added function report-lispval. Date: Wed Jan 26 05:49:24 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.46 movitz/losp/los0-gc.lisp:1.47 --- movitz/losp/los0-gc.lisp:1.46 Tue Jan 25 05:56:14 2005 +++ movitz/losp/los0-gc.lisp Wed Jan 26 05:49:24 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.46 2005/01/25 13:56:14 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.47 2005/01/26 13:49:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -102,40 +102,41 @@ (defun trigger-full-newspace (free-space) "Make it so that there's only free-space words left before newspace is full." - (let ((trigger (if (consp *gc-trigger*) - (pop *gc-trigger*) - *gc-trigger*))) - (when trigger - (macrolet - ((do-it () - `(with-inline-assembly (:returns :nothing) - retry - (:compile-form (:result-mode :eax) (+ free-space trigger)) - (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) - (:testl ,(logxor #xffffffff - (* #xfff movitz:+movitz-fixnum-factor+)) - :eax) - (:jnz '(:sub-program () (:int 64))) - (:addl 4 :eax) - (:andl -8 :eax) - (:movl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) - :ecx) - (:subl :eax :ecx) - (:movl (:edx 2) :ebx) - (:cmpl :ecx :ebx) - (:jc '(:sub-program () - ;; Current newspace was too full, so trigger a GC. - (:int 113) - (:jmp 'retry))) - (:movl :ecx (:edx 2)) - (:addl 8 :ebx) - fill-loop - (:movl :edi (:edx :ebx -6)) - (:addl 4 :ebx) - (:cmpl :ebx :ecx) - (:ja 'fill-loop) - ))) - (do-it))))) + (unless *gc-running* + (let ((trigger (if (consp *gc-trigger*) + (pop *gc-trigger*) + *gc-trigger*))) + (when trigger + (macrolet + ((do-it () + `(with-inline-assembly (:returns :nothing) + retry + (:compile-form (:result-mode :eax) (+ free-space trigger)) + (:locally (:movl (:edi (:edi-offset nursery-space)) :edx)) + (:testl ,(logxor #xffffffff + (* #xfff movitz:+movitz-fixnum-factor+)) + :eax) + (:jnz '(:sub-program () (:int 64))) + (:addl 4 :eax) + (:andl -8 :eax) + (:movl (:edx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)) + :ecx) + (:subl :eax :ecx) + (:movl (:edx 2) :ebx) + (:cmpl :ecx :ebx) + (:jc '(:sub-program () + ;; Current newspace was too full, so trigger a GC. + (:int 113) + (:jmp 'retry))) + (:movl :ecx (:edx 2)) + (:addl 8 :ebx) + fill-loop + (:movl :edi (:edx :ebx -6)) + (:addl 4 :ebx) + (:cmpl :ebx :ecx) + (:ja 'fill-loop) + ))) + (do-it)))))) (define-primitive-function los0-cons-pointer () @@ -156,7 +157,7 @@ (:ja '(:sub-program (probe-failed) (:int 113) (:int 63))) - (:movl :edi (:edx :ebx 8 ,movitz:+other-type-offset+)) + (:movl #xabbabee3 (:edx :ebx 8 ,movitz:+other-type-offset+)) ; a recognizable illegal value? (:leal (:edx :ebx 8) :eax) (:ret)))) (do-it))) @@ -405,6 +406,7 @@ (break "Seeing old object in values-vector: ~Z" x)) x) #x38 #xb8) + #+ignore (let* ((stack (%run-time-context-slot 'muerte::stack-vector)) (stack-start (- (length stack) (muerte::current-control-stack-depth)))) (do ((i 0 (+ i 3))) @@ -417,9 +419,6 @@ (+ (object-location stack) offender-index 2) (aref a (+ i 2)))))) - (loop for x from 0 to #xa0000 - do (when (= #x19a04e (memref x 0 :type :unsigned-byte32)) - (warn "Seeing foo at ~S." x))) (loop for i from stack-start below (length stack) as o = (aref stack i) do (when (and (typep o 'pointer) @@ -433,6 +432,7 @@ (format t "Old space [~Z]: ~/muerte:pprint-clumps/, new space [~Z]: ~ ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%" oldspace old-size newspace new-size (- old-size new-size)))) + (initialize-space oldspace) (fill oldspace #x13 :start 2) ;; (setf *gc-stack2* *gc-stack*) @@ -471,3 +471,16 @@ (+ 4 (object-location nursery) (space-fresh-pointer nursery)))) (map-stack-vector #'searcher nil (current-stack-frame)))) results)) + +(defun report-lispval (lispval &optional breakp newspace) + (let* ((location (truncate lispval 4)) + (newspace (or newspace (%run-time-context-slot 'muerte::nursery-space))) + (oldspace (space-other newspace))) + (cond + ((location-in-object-p newspace location) + (format t "#x~X is in newspace ~Z." lispval newspace)) + ((location-in-object-p oldspace location) + (funcall (if breakp 'break 'warn) "#x~X is in oldspace ~Z." lispval oldspace)) + (t (funcall (if breakp 'break 'warn) "#x~X is neither old nor new?" lispval)))) + (values)) + From ffjeld at common-lisp.net Thu Jan 27 07:46:54 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 26 Jan 2005 23:46:54 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: <20050127074654.CA431884FE@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18901 Modified Files: scavenge.lisp Log Message: Forgot an argument for match-funobj. Date: Wed Jan 26 23:46:51 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.41 movitz/losp/muerte/scavenge.lisp:1.42 --- movitz/losp/muerte/scavenge.lisp:1.41 Wed Jan 26 05:46:14 2005 +++ movitz/losp/muerte/scavenge.lisp Wed Jan 26 23:46:49 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.41 2005/01/26 13:46:14 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.42 2005/01/27 07:46:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -193,7 +193,7 @@ (cond ((location-in-object-p dit-code-vector location) dit-code-vector) - ((match-funobj esi)) + ((match-funobj esi location)) (t (break "DIT returns outside DIT??"))))) ((match-funobj casf-funobj location)) ((match-funobj esi location)) From ffjeld at common-lisp.net Thu Jan 27 07:47:38 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 26 Jan 2005 23:47:38 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-functions.lisp Message-ID: <20050127074738.4D45B884FE@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv18929 Modified Files: basic-functions.lisp Log Message: Removed some dead code. Date: Wed Jan 26 23:47:37 2005 Author: ffjeld Index: movitz/losp/muerte/basic-functions.lisp diff -u movitz/losp/muerte/basic-functions.lisp:1.15 movitz/losp/muerte/basic-functions.lisp:1.16 --- movitz/losp/muerte/basic-functions.lisp:1.15 Mon Dec 20 02:51:52 2004 +++ movitz/losp/muerte/basic-functions.lisp Wed Jan 26 23:47:37 2005 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2001-2004, +;;;; Copyright (C) 2001-2005, ;;;; Department of Computer Science, University of Tromso, Norway. ;;;; ;;;; For distribution policy, see the accompanying file COPYING. @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 4 18:41:57 2001 ;;;; -;;;; $Id: basic-functions.lisp,v 1.15 2004/12/20 10:51:52 ffjeld Exp $ +;;;; $Id: basic-functions.lisp,v 1.16 2005/01/27 07:47:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -349,18 +349,6 @@ (defun object-tag (object) (object-tag object)) - -;;;(define-compiler-macro object-location-offset (object) -;;; "The offset from the object's location to it's true address." -;;; `(with-inline-assembly (:returns :register) -;;; (:compile-form (:result-mode :register) ,object) -;;; (:shll ,movitz:+movitz-fixnum-shift+ (:result-register)) -;;; (:andl ,(* movitz:+movitz-fixnum-factor+ -;;; movitz:+movitz-fixnum-zmask+) -;;; (:result-register)))) -;;; -;;;(defun object-location-offset (object) -;;; (object-location-offset object)) (defun halt-cpu () (halt-cpu)) From ffjeld at common-lisp.net Thu Jan 27 07:48:55 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 26 Jan 2005 23:48:55 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/los0-gc.lisp Message-ID: <20050127074855.AB029884FE@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv18946 Modified Files: los0-gc.lisp Log Message: If a recursive GC is triggered, try to be slightly clever and allocate a new space that can be used by the debugger. Date: Wed Jan 26 23:48:53 2005 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.47 movitz/losp/los0-gc.lisp:1.48 --- movitz/losp/los0-gc.lisp:1.47 Wed Jan 26 05:49:24 2005 +++ movitz/losp/los0-gc.lisp Wed Jan 26 23:48:53 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.47 2005/01/26 13:49:24 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.48 2005/01/27 07:48:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -25,18 +25,6 @@ (defvar *gc-consitency-check* t) -(defun make-space (location size) - "Make a space vector at a fixed location." - (assert (evenp location)) - (macrolet ((x (index) - `(memref location 0 :index ,index :type :unsigned-byte32))) - (setf (x 1) (* #.movitz:+movitz-fixnum-factor+ size) - (x 0) #.(cl:dpb (bt:enum-value 'movitz:movitz-vector-element-type :u32) - (cl:byte 8 8) - (bt:enum-value 'movitz:other-type-byte :basic-vector)))) - (%word-offset location #.(movitz:tag :other))) - - (defmacro space-fresh-pointer (space) `(memref ,space -6 :index 2)) @@ -59,8 +47,32 @@ (setf (space-other space1) space2) space1)) -;;;(defun space-cons-pointer () -;;; (aref (%run-time-context-slot 'nursery-space) 0)) +(defun make-space (location size) + "Make a space vector at a fixed location." + (assert (evenp location)) + (macrolet ((x (index) + `(memref location 0 :index ,index :type :unsigned-byte32))) + (setf (x 1) (* #.movitz:+movitz-fixnum-factor+ size) + (x 0) #.(cl:dpb (bt:enum-value 'movitz:movitz-vector-element-type :u32) + (cl:byte 8 8) + (bt:enum-value 'movitz:other-type-byte :basic-vector)))) + (%word-offset location #.(movitz:tag :other))) + +(defun make-duo-space (location size) + (when (oddp location) + (incf location)) + (let ((space1 (make-space location size)) + (space2 (make-space (logand -4 (+ location 3 size)) size))) + (initialize-space space1) + (initialize-space space2) + (setf (space-other space1) space2 + (space-other space2) space1) + space1)) + +(defun duo-space-end-location (space1) + (let ((space2 (space-other space1))) + (max (+ (object-location space1) (length space2) 2) + (+ (object-location space2) (length space2) 2)))) (defun test () (warn "install..") @@ -229,12 +241,17 @@ (declare (ignore exception interrupt-frame)) (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)) + (cond + (*gc-running* + (let* ((full-space (%run-time-context-slot 'muerte::nursery-space)) + (hack-space (make-duo-space (duo-space-end-location full-space) 102400))) + (setf (%run-time-context-slot 'muerte::nursery-space) hack-space) + (break "Recursive GC triggered. Full-space: ~Z, hack-space: ~Z" + full-space hack-space))) + (t (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.. @@ -429,9 +446,9 @@ (unless *gc-quiet* (let ((old-size (truncate (- (space-fresh-pointer oldspace) 2) 2)) (new-size (truncate (- (space-fresh-pointer newspace) 2) 2))) - (format t "Old space [~Z]: ~/muerte:pprint-clumps/, new space [~Z]: ~ + (format t "Old space: ~/muerte:pprint-clumps/, new space: ~ ~/muerte:pprint-clumps/, freed: ~/muerte:pprint-clumps/.~%" - oldspace old-size newspace new-size (- old-size new-size)))) + old-size new-size (- old-size new-size)))) (initialize-space oldspace) (fill oldspace #x13 :start 2) From ffjeld at common-lisp.net Thu Jan 27 08:58:54 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 27 Jan 2005 00:58:54 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp Message-ID: <20050127085854.B4B228802A@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22332 Modified Files: special-operators-cl.lisp Log Message: Call anonymous functions (lambda ) rather than (:anonymous-lambda ...) Date: Thu Jan 27 00:58:53 2005 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.43 movitz/special-operators-cl.lisp:1.44 --- movitz/special-operators-cl.lisp:1.43 Tue Jan 25 05:44:11 2005 +++ movitz/special-operators-cl.lisp Thu Jan 27 00:58:53 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.43 2005/01/25 13:44:11 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.44 2005/01/27 08:58:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1014,7 +1014,7 @@ (multiple-value-bind (lambda-forms lambda-declarations) (parse-docstring-declarations-and-body (cddr name)) (let ((lambda-funobj - (make-compiled-funobj-pass1 '(:anonymous-lambda) + (make-compiled-funobj-pass1 '(muerte.cl:lambda) (cadr name) lambda-declarations `(muerte.cl:progn , at lambda-forms) From ffjeld at common-lisp.net Thu Jan 27 09:00:29 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 27 Jan 2005 01:00:29 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: <20050127090029.2137D8802A@common-lisp.net> Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22622 Modified Files: compiler.lisp Log Message: Changed slightly the compiler protocol such that register-function-code-size is called also for internal functions. Date: Thu Jan 27 01:00:27 2005 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.130 movitz/compiler.lisp:1.131 --- movitz/compiler.lisp:1.130 Tue Jan 25 05:42:39 2005 +++ movitz/compiler.lisp Thu Jan 27 01:00:25 2005 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.130 2005/01/25 13:42:39 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.131 2005/01/27 09:00:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -169,7 +169,6 @@ (let ((old-size (gethash hash-name (function-code-sizes *image*)))) (cond ((not old-size)) - ((eq name :anonymous-lambda)) ((not *warn-function-change-p*)) ((> new-size old-size) (warn "~S grew from ~D to ~D bytes." name old-size new-size)) @@ -234,10 +233,9 @@ "~&;; While Movitz compiling ~S in ~A:" name muerte.cl:*compile-file-pathname*))))) (with-retries-until-true (retry-funobj "Retry compilation of ~S." name) - (register-function-code-size - (make-compiled-funobj-pass2 - (make-compiled-funobj-pass1 name lambda-list declarations - form env top-level-p :funobj funobj)))))) + (make-compiled-funobj-pass2 + (make-compiled-funobj-pass1 name lambda-list declarations + form env top-level-p :funobj funobj))))) (defun make-compiled-funobj-pass1 (name lambda-list declarations form env top-level-p &key funobj) @@ -709,9 +707,9 @@ do (let ((sub-funobj (function-binding-funobj function-binding))) ;; (warn "USage: ~S => ~S" sub-funobj usage) (case (car (movitz-funobj-name sub-funobj)) - (:anonymous-lambda + ((muerte.cl:lambda) (setf (movitz-funobj-name sub-funobj) - (list :anonymous-lambda + (list 'lambda (movitz-funobj-name toplevel-funobj) (post-incf sub-funobj-index))))) (loop for borrowed-binding in (borrowed-bindings sub-funobj) @@ -793,7 +791,7 @@ (t (complete-funobj-default funobj))) (loop for (sub-function-binding) on (sub-function-binding-usage funobj) by #'cddr do (complete-funobj (function-binding-funobj sub-function-binding))) - funobj) + (register-function-code-size funobj)) (defun complete-funobj-1req1opt (funobj) (assert (= 2 (length (function-envs funobj)))) From ffjeld at common-lisp.net Thu Jan 27 09:01:28 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 27 Jan 2005 01:01:28 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: <20050127090128.94A798802A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23073 Modified Files: scavenge.lisp Log Message: Fixed the situation when an interrupt occures inside dynamic-jump-next. Date: Thu Jan 27 01:01:27 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.42 movitz/losp/muerte/scavenge.lisp:1.43 --- movitz/losp/muerte/scavenge.lisp:1.42 Wed Jan 26 23:46:49 2005 +++ movitz/losp/muerte/scavenge.lisp Thu Jan 27 01:01:27 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.42 2005/01/27 07:46:49 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.43 2005/01/27 09:01:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -199,9 +199,16 @@ ((match-funobj esi location)) ((not (typep casf-funobj 'function)) (break "Unknown funobj/frame-type: ~S" casf-funobj)) + ((location-in-object-p (%run-time-context-slot 'dynamic-jump-next) location) + (%run-time-context-slot 'dynamic-jump-next)) ((when searchp (%find-code-vector location))) - (t (error "Unable to decode EIP #x~X funobj ~S." location casf-funobj))))) + (t (with-simple-restart (continue "Try to perform a code-vector-search.") + (error "Unable to decode EIP #x~X funobj ~S, ESI ~S." + (* 4 location) casf-funobj esi)) + (or (%find-code-vector location) + (error "Code-vector-search for EIP #x~X also failed." + (* 4 location))))))) (defun map-stack-value (function value frame) (if (not (typep value 'pointer)) @@ -305,7 +312,6 @@ (eq x1-tag 3) ; 3 or 7? (and (oddp x1-location) (eq x1-tag 2))) ; 6? (location-in-object-p casf-code-vector x1-location)) - (warn "X1: ~S ~S" x1-location x1-tag) (let* ((old-x1-code-vector (scavenge-find-code-vector (stack-frame-ref nil next-eip-index 0 :location) casf-funobj interrupted-esi t))) From ffjeld at common-lisp.net Thu Jan 27 11:19:56 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 27 Jan 2005 03:19:56 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp Message-ID: <20050127111956.2D7658802C@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv30105 Modified Files: debugger.lisp Log Message: Tweaked *call-site-patterns*. Date: Thu Jan 27 03:19:55 2005 Author: ffjeld Index: movitz/losp/x86-pc/debugger.lisp diff -u movitz/losp/x86-pc/debugger.lisp:1.29 movitz/losp/x86-pc/debugger.lisp:1.30 --- movitz/losp/x86-pc/debugger.lisp:1.29 Fri Jan 21 13:02:45 2005 +++ movitz/losp/x86-pc/debugger.lisp Thu Jan 27 03:19:53 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 22 10:09:18 2002 ;;;; -;;;; $Id: debugger.lisp,v 1.29 2005/01/21 21:02:45 ffjeld Exp $ +;;;; $Id: debugger.lisp,v 1.30 2005/01/27 11:19:53 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -225,7 +225,8 @@ (:* 1 ((:or ((:or (#x8b #x56 (:edx :esi)) ; (:movl (:esi x) :edx) (#x8b #x54 #x37 (:edx :esi+edi))) ;# %EDX> #x8b #x72 #xfd) ; (:movl (:edx -3) :esi) - (#x8b #x74 #x7e (:any-offset))))) ; # %ESI> + (#x8b #x74 #x7e (:any-offset)) ; # %ESI> + (#x8b #x76 (:any-offset))))) ; # %ESI> (:* 1 ((:or (#xb1 (:cl-numargs))))) ; (:movb x :cl) (:* 1 ((:or (#x8b #x55 (:edx :ebp)) (#x8b #x56 (:edx :esi))))) From ffjeld at common-lisp.net Fri Jan 28 08:47:19 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 28 Jan 2005 00:47:19 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/scavenge.lisp Message-ID: <20050128084719.DB94A88394@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv418 Modified Files: scavenge.lisp Log Message: Fixed a typo in match-funobj, and removed the old scavenge function that's now defunct. Date: Fri Jan 28 00:47:18 2005 Author: ffjeld Index: movitz/losp/muerte/scavenge.lisp diff -u movitz/losp/muerte/scavenge.lisp:1.43 movitz/losp/muerte/scavenge.lisp:1.44 --- movitz/losp/muerte/scavenge.lisp:1.43 Thu Jan 27 01:01:27 2005 +++ movitz/losp/muerte/scavenge.lisp Fri Jan 28 00:47:18 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Mar 29 14:54:08 2004 ;;;; -;;;; $Id: scavenge.lisp,v 1.43 2005/01/27 09:01:27 ffjeld Exp $ +;;;; $Id: scavenge.lisp,v 1.44 2005/01/28 08:47:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -173,17 +173,17 @@ (cond ((not (typep funobj 'function)) nil) - ((let ((x (funobj-code-vector casf-funobj))) + ((let ((x (funobj-code-vector funobj))) (and (location-in-object-p x location) x))) - ((let ((x (funobj-code-vector%1op casf-funobj))) + ((let ((x (funobj-code-vector%1op funobj))) (and (typep x 'vector) (location-in-object-p x location) x))) - ((let ((x (funobj-code-vector%2op casf-funobj))) + ((let ((x (funobj-code-vector%2op funobj))) (and (typep x 'vector) (location-in-object-p x location) x))) - ((let ((x (funobj-code-vector%3op casf-funobj))) + ((let ((x (funobj-code-vector%3op funobj))) (and (typep x 'vector) (location-in-object-p x location) x)))))) @@ -340,145 +340,4 @@ old) (t (setf (stack-frame-ref nil index 0) nil))))) - -#+ignore -(defun old-map-stack-vector (function stack start-frame &optional (map-region #'map-header-vals)) - "Map function over the potential pointer words of a stack, starting -at the start-stack-frame location." - (with-funcallable (map-region) - (loop with next-frame with next-nether-frame - for nether-frame = start-frame then (or next-nether-frame frame) - and frame = (stack-frame-uplink stack start-frame) then (or next-frame - (stack-frame-uplink stack frame)) - while (plusp frame) - do (setf next-frame nil next-nether-frame nil) - do (flet ((scavenge-funobj-code-vector (funobj) - "Funobj 0 is assumed to be the DIT code-vector." - (if (eq 0 funobj) - (symbol-value 'default-interrupt-trampoline) - (funobj-code-vector funobj)))) - (let ((funobj (funcall function (stack-frame-funobj stack frame) frame))) - ;; If nether-frame is a DIT-frame, there are 4 more words to be skipped. - (when (eq 0 (stack-frame-ref stack nether-frame -1)) - (incf nether-frame 4)) - (typecase funobj - ((or function null) - (assert (= 0 (funobj-frame-raw-locals funobj))) - (map-region function (+ nether-frame 2) frame)) - ((eql 0) ; A dit interrupt-frame? - (let* ((dit-frame frame) - (casf-frame (dit-frame-casf stack dit-frame))) - ;; 1. Scavenge the dit-frame - (cond - ((let ((atomically (dit-frame-ref stack dit-frame :atomically-continuation - :unsigned-byte32))) - (and (not (= 0 atomically)) - (= 0 (ldb (byte 2 0) atomically)))) - ;; Interrupt occurred inside an (non-pf) atomically, so none of the - ;; registers are active. - (map-region function (+ nether-frame 2) - (+ dit-frame 1 (dit-frame-index :tail-marker)))) - ((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 stack dit-frame :eip :unsigned-byte32)) - (map-region function ; Assume nothing in the dit-frame above the location .. - (+ nether-frame 2) ; ..of EDX holds pointers. - (+ dit-frame (dit-frame-index :edx)))) - (t #+ignore (warn "Interrupt in COMMON mode!") - (map-region function ; Assume nothing in the dit-frame above the location .. - (+ nether-frame 2) ; ..of ECX holds pointers. - (+ dit-frame (dit-frame-index :ecx))))) - ;; 2. Pop to (dit-)frame's CASF - (setf nether-frame dit-frame - frame casf-frame #+ignore (dit-frame-casf stack frame)) - (let ((eip-location (dit-frame-ref stack dit-frame :eip :location)) - (interrupted-esp (dit-frame-esp stack dit-frame)) - (interrupted-ebp (dit-frame-ref stack dit-frame :ebp)) - (casf-funobj (funcall function (stack-frame-funobj stack frame) frame))) - (cond - ((or (eq 0 casf-funobj) - (typep casf-funobj 'function)) - (let ((casf-code-vector (scavenge-funobj-code-vector casf-funobj))) - ;; 3. Scavenge the interrupted frame, according to one of i. ii. or iii. - (cond - ((eq nil interrupted-ebp) - (cond - ((location-in-object-p casf-code-vector eip-location) - (warn "DIT at throw situation, in target ~S at ~S" - casf-funobj - (dit-frame-ref stack dit-frame :eip :unsigned-byte32)) - (map-region function interrupted-esp frame)) - ((location-in-object-p (%run-time-context-slot 'dynamic-jump-next) - eip-location) - (warn "DIT at throw situation, in dynamic-jump-next.") - (let ((dynamic-env (dit-frame-ref stack dit-frame :dynamic-env))) - (assert (< dynamic-env frame)) - (map-region function dynamic-env frame))) - (t (error "Unknown throw situation with EBP=~S, ESP=~S" - interrupted-ebp interrupted-esp)))) - ((location-in-object-p casf-code-vector - (dit-frame-ref stack dit-frame :eip :location)) - (cond - ((let ((x0-tag (ldb (byte 3 0) - (memref interrupted-esp 0 :type :unsigned-byte8)))) - (and (member x0-tag '(1 5 6 7)) - (location-in-object-p casf-code-vector - (memref interrupted-esp 0 :type :location)))) - ;; When code-vector migration is implemented... - (warn "Scanning at ~S X0 call ~S in ~S." - (dit-frame-ref stack dit-frame :eip :unsigned-byte32) - (memref interrupted-esp 0 :type :unsigned-byte32) - (funobj-name casf-funobj)) - (when (eq 0 (stack-frame-ref stack frame -1)) - (break "X1 call in DIT-frame.")) - (map-region function (+ interrupted-esp 1) frame) - (setf next-frame frame - next-nether-frame (+ interrupted-esp 1 -2))) - ((let ((x1-tag (ldb (byte 3 0) - (memref interrupted-esp 4 :type :unsigned-byte8)))) - (and (member x1-tag '(1 5 6 7)) - (location-in-object-p casf-code-vector - (memref interrupted-esp 4 :type :location)))) - ;; When code-vector migration is implemented... - (warn "Scanning at ~S X1 call ~S in ~S." - (dit-frame-ref stack dit-frame :eip :unsigned-byte32) - (memref interrupted-esp 4 :type :unsigned-byte32) - (funobj-name casf-funobj)) - (when (eq 0 (stack-frame-ref stack frame -1)) - (break "X1 call in DIT-frame.")) - (map-region function (+ interrupted-esp 2) frame) - (setf next-frame frame - next-nether-frame (+ interrupted-esp 2 -2))) - (t ;; Situation i. Nothing special on stack, scavenge frame normally. - ;; (map-region function interrupted-esp frame) - (setf next-frame frame - next-nether-frame (- interrupted-esp 2)) - ))) - ((eq casf-frame (memref interrupted-esp 0 :type :location)) - ;; Situation ii. esp(0)=CASF, esp(1)=code-vector - (assert (location-in-object-p casf-code-vector - (memref interrupted-esp 4 :type :location)) - - () "Stack discipline situation ii. invariant broken. CASF=#x~X, ESP=~S, EBP=~S" - casf-frame interrupted-esp interrupted-ebp) - (when (eq 0 (stack-frame-ref stack frame -1)) - (break "X1 ii call in DIT-frame.")) - (map-region function (+ interrupted-esp 2) frame) - (setf next-frame frame - next-nether-frame (+ interrupted-esp 2 -2))) - (t ;; Situation iii. esp(0)=code-vector. - (assert (location-in-object-p casf-code-vector - (memref interrupted-esp 0 :type :location)) - () "Stack discipline situation iii. invariant broken. CASF=#x~X" - casf-frame) - (when (eq 0 (stack-frame-ref stack frame -1)) - (break "X1 iii call in DIT-frame.")) - (map-region function (+ interrupted-esp 1) frame) - (setf next-frame frame - next-nether-frame (+ interrupted-esp 1 -2)))))) - (t (error "DIT-frame interrupted unknown CASF funobj: ~Z, CASF ~S" - casf-funobj casf-frame)))))) - (t (error "Don't know how to scavenge across frame ~S of kind ~S." frame funobj))))))) - (values)) From ffjeld at common-lisp.net Fri Jan 28 08:49:08 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Fri, 28 Jan 2005 00:49:08 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp Message-ID: <20050128084908.E037A88394@common-lisp.net> Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv439 Modified Files: interrupt.lisp Log Message: Fixed dit-frame-casf according to the (newish) stack discipline. Date: Fri Jan 28 00:49:07 2005 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.36 movitz/losp/muerte/interrupt.lisp:1.37 --- movitz/losp/muerte/interrupt.lisp:1.36 Tue Jan 25 05:50:16 2005 +++ movitz/losp/muerte/interrupt.lisp Fri Jan 28 00:49:07 2005 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.36 2005/01/25 13:50:16 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.37 2005/01/28 08:49:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -82,20 +82,17 @@ (let ((ebp (dit-frame-ref stack dit-frame :ebp)) (esp (dit-frame-esp stack dit-frame))) (cond - ((null ebp) ; special mode + ((null ebp) ; special dynamic control-transfer mode (stack-frame-ref stack (dit-frame-ref stack dit-frame :dynamic-env) 0)) ((< esp ebp) ebp) - ((> esp ebp) - ;; A throw situation + ((eq esp ebp) (let ((next-ebp (stack-frame-ref stack esp 0))) (check-type next-ebp fixnum) (assert (< esp 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))))) + (t (error "Undefined CASF for dit-frame ~S with EBP #x~X and ESP #x~X." + dit-frame ebp esp))))) (define-primitive-function (default-interrupt-trampoline :symtab-property t) () "Default first-stage/trampoline interrupt handler. Assumes the IF flag in EFLAGS From ffjeld at common-lisp.net Sat Jan 29 10:32:58 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 29 Jan 2005 02:32:58 -0800 (PST) Subject: [movitz-cvs] CVS update: movitz/doc/ChangeLog Message-ID: <20050129103258.7B7C88802A@common-lisp.net> Update of /project/movitz/cvsroot/movitz/doc In directory common-lisp.net:/tmp/cvs-serv16868 Modified Files: ChangeLog Log Message: *** empty log message *** Date: Sat Jan 29 02:32:57 2005 Author: ffjeld Index: movitz/doc/ChangeLog diff -u movitz/doc/ChangeLog:1.9 movitz/doc/ChangeLog:1.10 --- movitz/doc/ChangeLog:1.9 Tue Jan 4 12:33:17 2005 +++ movitz/doc/ChangeLog Sat Jan 29 02:32:57 2005 @@ -1,3 +1,12 @@ +2005-01-29 Frode Vatvedt Fjeld + + * There's been quite a bit of work on scavenge.lisp. The stack scavenging + has been re-designed completely, and should now not break as it + sometimes did before in certain interrupt + situations. Interestingly, the scavenging API essentially didn't + change at all. There are still some holes left empty when it comes + to migrating code-vectors, but this should be trivial to fix. + 2005-01-04 Frode Vatvedt Fjeld * Fixed some support for stack-allocating funobjs and cons-cells From ffjeld at common-lisp.net Sat Jan 29 10:36:57 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 29 Jan 2005 02:36:57 -0800 (PST) Subject: [movitz-cvs] CVS update: public_html/index.html Message-ID: <20050129103657.90BBD8802A@common-lisp.net> Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv16922 Modified Files: index.html Log Message: *** empty log message *** Date: Sat Jan 29 02:36:56 2005 Author: ffjeld Index: public_html/index.html diff -u public_html/index.html:1.21 public_html/index.html:1.22 --- public_html/index.html:1.21 Sun Dec 12 04:38:40 2004 +++ public_html/index.html Sat Jan 29 02:36:56 2005 @@ -15,6 +15,11 @@

Most recent news

+

January 29, 2005 The stack discipline and associated GC + scavenging routines have been cleaned up, now hopefully work as they + should, even in the corner cases when two interrupts occur in rapid + succession etc. +

December 12, 2004: Various bits and pieces have been cleaned up so that recent (2.33) CLisp can now compile Movitz kernels just fine (mostly to do with CLisp having CL symbols with e.g. CLOS From ffjeld at common-lisp.net Sat Jan 29 10:38:48 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 29 Jan 2005 02:38:48 -0800 (PST) Subject: [movitz-cvs] CVS update: public_html/index.html Message-ID: <20050129103848.420D58802A@common-lisp.net> Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv16960 Modified Files: index.html Log Message: *** empty log message *** Date: Sat Jan 29 02:38:47 2005 Author: ffjeld Index: public_html/index.html diff -u public_html/index.html:1.22 public_html/index.html:1.23 --- public_html/index.html:1.22 Sat Jan 29 02:36:56 2005 +++ public_html/index.html Sat Jan 29 02:38:47 2005 @@ -20,6 +20,9 @@ should, even in the corner cases when two interrupts occur in rapid succession etc. +

January 4, 2005 Fixed some support for stack-allocating + funobjs and cons-cells of dynamic extent. +

December 12, 2004: Various bits and pieces have been cleaned up so that recent (2.33) CLisp can now compile Movitz kernels just fine (mostly to do with CLisp having CL symbols with e.g. CLOS From ffjeld at common-lisp.net Sat Jan 29 10:42:29 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 29 Jan 2005 02:42:29 -0800 (PST) Subject: [movitz-cvs] CVS update: public_html/ChangeLog public_html/index.html Message-ID: <20050129104229.92C918802A@common-lisp.net> Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv17004 Modified Files: index.html Added Files: ChangeLog Log Message: moved this here. Date: Sat Jan 29 02:42:28 2005 Author: ffjeld Index: public_html/index.html diff -u public_html/index.html:1.23 public_html/index.html:1.24 --- public_html/index.html:1.23 Sat Jan 29 02:38:47 2005 +++ public_html/index.html Sat Jan 29 02:42:28 2005 @@ -39,7 +39,7 @@ with Movitz, and which is now fixed in QEMU's CVS.

For more news, see the ChangeLog. + href="ChangeLog">ChangeLog.

Introduction

From ffjeld at common-lisp.net Sat Jan 29 16:33:32 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sat, 29 Jan 2005 08:33:32 -0800 (PST) Subject: [movitz-cvs] CVS update: ia-x86/README Message-ID: <20050129163332.24B2A8802D@common-lisp.net> Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv3027 Added Files: README Log Message: First few lines. Date: Sat Jan 29 08:33:31 2005 Author: ffjeld From ffjeld at common-lisp.net Sun Jan 30 11:35:17 2005 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 30 Jan 2005 03:35:17 -0800 (PST) Subject: [movitz-cvs] CVS update: ia-x86/README Message-ID: <20050130113517.61B808802A@common-lisp.net> Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv29444 Modified Files: README Log Message: *** empty log message *** Date: Sun Jan 30 03:35:16 2005 Author: ffjeld Index: ia-x86/README diff -u ia-x86/README:1.1 ia-x86/README:1.2 --- ia-x86/README:1.1 Sat Jan 29 08:33:31 2005 +++ ia-x86/README Sun Jan 30 03:35:16 2005 @@ -10,7 +10,7 @@ ## Author: Frode Vatvedt Fjeld ## Created at: Sat Jan 29 16:48:42 2005 ## -## $Id: README,v 1.1 2005/01/29 16:33:31 ffjeld Exp $ +## $Id: README,v 1.2 2005/01/30 11:35:16 ffjeld Exp $ ## ###################################################################### @@ -22,7 +22,7 @@ the Movitz compiler. The following documents the most interesting API operators for this package. -A few terms requires explanation. A "proglist" is a representation of +A few terms requires explanation. A "program" is a representation of an assembly program that is reasonably convenient to work with for humans. This is a list, whose elements are either a symbol that represents a label, or a list that represents an instruction. The @@ -31,10 +31,70 @@ by 1" (more on this syntax below). However, instructions are also represented internally ia-x86 by instances of the various subclasses of the "instruction" standard-class, and lists of such objects are -also someplaces referred to as proglists. +referred to as "proglists". Assembly +The function read-proglist reads a program into proglist form, which +is typically the first step in producing machine code. This function +(and its helper functions, in read.lisp) defines the human-readable +syntax for assembly programs. This is an example program (or rather, a +lisp function that produces an assembly program): + + (defun mkasm16-bios-print () + "Print something to the terminal. [es:si] points to the text" + `((:movzxb (:si) :cx) + (:incw :si) + (:movb #xe :ah) + (:movw 7 :bx) + print-loop + (:lodsb) + (:int #x10) + (:loop 'print-loop) + (:ret))) + +I personally tend to use keywords for instruction names, although the +instructions are recognized by name rather than identity, so any +package will do. Labels, however, are recognized by identity. Label +references are on the form (quote