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

[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
by Frode Vatvedt Fjeld 11 Oct '04

11 Oct '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30369 Modified Files: special-operators-cl.lisp Log Message: Make "lexical" unwind-protects work (for some definition of work..) Date: Mon Oct 11 15:48:07 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.26 movitz/special-operators-cl.lisp:1.27 --- movitz/special-operators-cl.lisp:1.26 Fri Oct 8 12:26:38 2004 +++ movitz/special-operators-cl.lisp Mon Oct 11 15:48:07 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.26 2004/10/08 10:26:38 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.27 2004/10/11 13:48:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -721,7 +721,9 @@ (movitz-env-get tag 'go-tag nil env) (assert (and label tagbody-env) () "Go-tag ~W is not visible." tag) - (if (eq funobj (movitz-environment-funobj tagbody-env)) + (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))) @@ -1210,6 +1212,7 @@ (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))

1 0

[movitz-cvs] CVS update: movitz/eval.lisp
by Frode Vatvedt Fjeld 11 Oct '04

11 Oct '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30338 Modified Files: eval.lisp Log Message: Make movitz-constantp and movitz-eval understand compiler-macros. Date: Mon Oct 11 15:46:57 2004 Author: ffjeld Index: movitz/eval.lisp diff -u movitz/eval.lisp:1.7 movitz/eval.lisp:1.8 --- movitz/eval.lisp:1.7 Wed Jul 21 16:14:29 2004 +++ movitz/eval.lisp Mon Oct 11 15:46:56 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 2 17:45:05 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: eval.lisp,v 1.7 2004/07/21 14:14:29 ffjeld Exp $ +;;;; $Id: eval.lisp,v 1.8 2004/10/11 13:46:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -56,29 +56,41 @@ (eq 'muerte.cl::quote (first x))) t)) -(defun movitz-constantp (form &optional (environment nil)) - (let ((form (translate-program form :cl :muerte.cl))) - (typecase form - (keyword t) - (symbol (or (movitz-env-get form 'constantp nil environment) - (typep (movitz-binding form environment) 'constant-object-binding))) - (cons (case (car form) - ((muerte.cl:quote) t) - ((muerte.cl:not) - (movitz-constantp (second form))) - ((muerte.cl:+ muerte.cl:- muerte.cl:* muerte.cl:coerce) - (every (lambda (sub-form) - (movitz-constantp sub-form environment)) - (cdr form))))) - (t t)))) ; anything else is self-evaluating. - - -(defun isconst (x) - (or (integerp x) - (stringp x) - (eq t x) - (eq nil x) - (quote-form-p x))) +(defun movitz-constantp (form &optional (env nil)) + (typecase form + (keyword t) + (symbol + (let ((form (translate-program form :cl :muerte.cl))) + (or (movitz-env-get form 'constantp nil env) + (typep (movitz-binding form env) 'constant-object-binding)))) + (cons + (let* ((compiler-macro-function (movitz-compiler-macro-function (car form) env)) + (compiler-macro-expansion (and compiler-macro-function + (funcall *movitz-macroexpand-hook* + compiler-macro-function + form env)))) + (or (let ((form (translate-program form :cl :muerte.cl))) + (case (car form) + ((muerte.cl:quote) t) + ((muerte.cl:not) + (movitz-constantp (second form))) + ((muerte.cl:+ muerte.cl:- muerte.cl:* muerte.cl:coerce) + (every (lambda (sub-form) + (movitz-constantp sub-form env)) + (cdr form))))) + (and compiler-macro-function + (not (movitz-env-get (car form) 'notinline nil env)) + (not (eq form compiler-macro-expansion)) + (movitz-constantp compiler-macro-expansion env))))) + (t t))) ; anything else is self-evaluating. + + +;;;(defun isconst (x) +;;; (or (integerp x) +;;; (stringp x) +;;; (eq t x) +;;; (eq nil x) +;;; (quote-form-p x))) (defun eval-form (&rest args) (apply 'movitz-eval args)) @@ -115,11 +127,32 @@ (defun eval-cons (form env top-level-p) "3.1.2.1.2 Conses as Forms" - (let ((operator (car form))) - (declare (ignore operator)) + (let* ((operator (car form)) + (compiler-macro-function (movitz-compiler-macro-function operator env)) + (compiler-macro-expansion (and compiler-macro-function + (funcall *movitz-macroexpand-hook* + compiler-macro-function + form env)))) (cond - ((movitz-constantp form env) - (eval-constant-compound form env top-level-p)) +;;; ((movitz-constantp form env) +;;; (eval-constant-compound form env top-level-p)) + ((member operator '(cl:quote muerte.cl::quote)) + (eval-self-evaluating (second form) env top-level-p)) + ((member operator '(muerte.cl::not)) + (not (eval-form (second form) env nil))) + ((member operator '(muerte.cl:+ muerte.cl:- muerte.cl:*)) + (apply (translate-program (car form) :muerte.cl :cl) + (mapcar (lambda (sub-form) + (movitz-eval sub-form env nil)) + (cdr form)))) + ((member operator '(muerte.cl:coerce)) + (apply #'coerce + (mapcar (lambda (arg) (movitz-eval arg env nil)) + (cdr form)))) + ((and compiler-macro-function + (not (movitz-env-get (car form) 'notinline nil env)) + (not (eq form compiler-macro-expansion))) + (movitz-eval compiler-macro-expansion env top-level-p)) ;;; ((lambda-form-p form) ;;; (eval-lambda-form form env top-level-p)) ;;; ((symbolp operator)

1 0

[movitz-cvs] CVS update: movitz/environment.lisp
by Frode Vatvedt Fjeld 11 Oct '04

11 Oct '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30213 Modified Files: environment.lisp Log Message: Some tweaking of the environment object for unwind-protects. Date: Mon Oct 11 15:46:26 2004 Author: ffjeld Index: movitz/environment.lisp diff -u movitz/environment.lisp:1.8 movitz/environment.lisp:1.9 --- movitz/environment.lisp:1.8 Thu Oct 7 14:41:41 2004 +++ movitz/environment.lisp Mon Oct 11 15:46:25 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 3 11:40:15 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: environment.lisp,v 1.8 2004/10/07 12:41:41 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.9 2004/10/11 13:46:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -229,11 +229,15 @@ (defclass tagbody-env (lexical-exit-point-env) ()) (defclass unwind-protect-env (movitz-environment) - ()) + ((cleanup-form + :initarg :cleanup-form + :reader unwind-protect-env-cleanup-form))) (defmethod num-dynamic-slots ((x unwind-protect-env)) 1) -(defclass simple-dynamic-env (with-things-on-stack-env) () +(defclass simple-dynamic-env (with-things-on-stack-env) + ((stack-used + :initform 4)) (:documentation "An environment that installs one dynamic-env.")) (defmethod num-dynamic-slots ((x simple-dynamic-env)) 1)

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 11 Oct '04

11 Oct '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29398 Modified Files: compiler.lisp Log Message: Some variables should be defparameteres, not defvars. Date: Mon Oct 11 15:44:05 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.100 movitz/compiler.lisp:1.101 --- movitz/compiler.lisp:1.100 Fri Oct 8 14:16:08 2004 +++ movitz/compiler.lisp Mon Oct 11 15:44:04 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.100 2004/10/08 12:16:08 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.101 2004/10/11 13:44:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -44,14 +44,14 @@ "Use these assembly-instruction prefixes when accessing the global run-time context.") -(defvar *compiler-physical-segment-prefix* '(:gs-override) +(defparameter *compiler-physical-segment-prefix* '(:gs-override) "Use this instruction prefix when accessing a physical memory location (i.e. typically some memory-mapped hardware device).") -(defvar *compiler-nonlocal-lispval-read-segment-prefix* '(:fs-override) +(defparameter *compiler-nonlocal-lispval-read-segment-prefix* '(:fs-override) "Use this segment prefix when reading a lispval at (potentially) non-local locations.") -(defvar *compiler-nonlocal-lispval-write-segment-prefix* '(:fs-override) +(defparameter *compiler-nonlocal-lispval-write-segment-prefix* '(:fs-override) "Use this segment prefix when writing a lispval at (potentially) non-local locations.")

1 0

[movitz-cvs] CVS update: movitz/compiler.lisp
by Frode Vatvedt Fjeld 08 Oct '04

08 Oct '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv16138 Modified Files: compiler.lisp Log Message: Fixed buglet in stack-delta that would barf in some situations. Date: Fri Oct 8 14:16:11 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.99 movitz/compiler.lisp:1.100 --- movitz/compiler.lisp:1.99 Wed Sep 15 12:22:52 2004 +++ movitz/compiler.lisp Fri Oct 8 14:16:08 2004 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.99 2004/09/15 10:22:52 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.100 2004/10/08 12:16:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5789,10 +5789,6 @@ (:jne ',push-values-loop) ,push-values-done))) -;;;(:load-lexical ,numargs-binding :eax) -;;; (:addl :ecx :eax) -;;; (:store-lexical ,numargs-binding :eax :type fixnum)))) - (defun stack-delta (inner-env outer-env) "Calculate the amount of stack-space used (in 32-bit stack slots) at the time of <inner-env> since <outer-env>, @@ -5807,9 +5803,8 @@ (cond ((eq outer-env env) ;; Each dynamic-slot is 4 stack-distances, so let's check that.. - (unless (>= stack-distance (* 4 num-dynamic-slots)) - (print-stack-delta inner-env outer-env)) - (assert (>= stack-distance (* 4 num-dynamic-slots)) () + (assert (or (eq t stack-distance) + (>= stack-distance (* 4 num-dynamic-slots))) () "The stack-distance ~D is smaller than number of dynamic-slots ~D, which is inconsistent." stack-distance num-dynamic-slots) (values stack-distance num-dynamic-slots unwind-protects))

1 0

[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
by Frode Vatvedt Fjeld 08 Oct '04

08 Oct '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv9027 Modified Files: special-operators-cl.lisp Log Message: Fix non-local go to work across unwind-protects. Date: Fri Oct 8 12:26:38 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.25 movitz/special-operators-cl.lisp:1.26 --- movitz/special-operators-cl.lisp:1.25 Thu Oct 7 14:52:47 2004 +++ movitz/special-operators-cl.lisp Fri Oct 8 12:26:38 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.25 2004/10/07 12:52:47 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.26 2004/10/08 10:26:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -725,20 +725,18 @@ (compiler-values () :returns :non-local-exit :code `((:lexical-control-transfer nil :nothing ,env ,tagbody-env ,label))) - ;; Perform a lexical "throw" to the tag. Much like a regular throw, except - ;; no values are transferred, and we step _into_ that dynamic env, not outside it. + ;; 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) - #+ignore - (compiler-call #'compile-form-unprotected - :forward all - :form `(muerte::exact-throw ,(movitz-env-lexical-catch-tag-variable tagbody-env) - 0 nil)) (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)))) (:globally (:call (:edi (:edi-offset dynamic-unwind-next)))) (:jnc '(:sub-program () (:int 63))) ;; have next-continuation in EAX, final-continuation in EDX @@ -749,26 +747,8 @@ (:movl (:esp) :eax) ; target stack-frame EBP (:movl (:eax -4) :esi) ; get target funobj into ESI (:movl (:esp 8) :eax) ; target jumper number - (:jmp (:esi :eax - ,(* 4 label-id) ,(slot-offset 'movitz-funobj 'constant0))))) - #+ignore - (compiler-values () - :returns :non-local-exit - :code (append (compiler-call #'compile-form - :result-mode :eax - :forward all - :form (movitz-env-lexical-catch-tag-variable tagbody-env)) - `((:xorl :ebx :ebx) - (:globally (:call (:edi (:edi-offset dynamic-locate-catch-tag)))) - (:jnc '(:sub-program () (:int 108))) - (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax)) - (:movl :eax :esp) - (:movl (:esp) :ebp) - (:movl (:ebp -4) :esi) - (:locally (:movl :eax (:edi (:edi-offset dynamic-env)))) ; enter dynamic env - (:movl (:esp 8) :ecx) ; label-set base - (:jmp (:esi :ecx ,(+ (slot-offset 'movitz-funobj 'constant0) - (* 4 label-id)))))))))))) ; transfer control, finally. + (:clc) + (:jmp (:esi :eax ,(slot-offset 'movitz-funobj 'constant0)))))))))) (define-special-operator block (&all forward &funobj funobj &form form &env env &result-mode result-mode)

1 0

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

07 Oct '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv26324 Modified Files: los0-gc.lisp Log Message: Minor edits. Date: Thu Oct 7 14:54:43 2004 Author: ffjeld Index: movitz/losp/los0-gc.lisp diff -u movitz/losp/los0-gc.lisp:1.40 movitz/losp/los0-gc.lisp:1.41 --- movitz/losp/los0-gc.lisp:1.40 Fri Oct 1 14:44:20 2004 +++ movitz/losp/los0-gc.lisp Thu Oct 7 14:54:43 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Feb 21 17:48:32 2004 ;;;; -;;;; $Id: los0-gc.lisp,v 1.40 2004/10/01 12:44:20 ffjeld Exp $ +;;;; $Id: los0-gc.lisp,v 1.41 2004/10/07 12:54:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -270,10 +270,6 @@ (+ 1 (object-location space) (array-dimension space 0))))) -(defun tenure () - (install-old-consing) - (install-los0-consing)) - (defun report-nursery (x location) "Write a message if x is inside newspace." (when (object-in-space-p (%run-time-context-slot 'nursery-space) x) @@ -293,6 +289,12 @@ find-location x location)) x)) +#+ignore +(defun tenure () + (install-old-consing) + (install-los0-consing)) + +#+ignore (defun kill-the-newborns () (let* ((oldspace (%run-time-context-slot 'nursery-space)) (newspace (space-other oldspace)))

1 0

[movitz-cvs] CVS update: movitz/special-operators-cl.lisp
by Frode Vatvedt Fjeld 07 Oct '04

07 Oct '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26284 Modified Files: special-operators-cl.lisp Log Message: Fixed tagbody/go for stack discipline. Date: Thu Oct 7 14:52:48 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.24 movitz/special-operators-cl.lisp:1.25 --- movitz/special-operators-cl.lisp:1.24 Fri Sep 17 13:12:47 2004 +++ movitz/special-operators-cl.lisp Thu Oct 7 14:52:47 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Nov 24 16:31:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: special-operators-cl.lisp,v 1.24 2004/09/17 11:12:47 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.25 2004/10/07 12:52:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -624,10 +624,13 @@ :returns last-returns :functional-p nil)))) -(define-special-operator tagbody (&all forward &funobj funobj &form form &env env &result-mode result-mode) +(define-special-operator tagbody + (&all forward &funobj funobj &form form &env env) (let* ((save-esp-variable (gensym "tagbody-save-esp")) (lexical-catch-tag-variable (gensym "tagbody-lexical-catch-tag-")) - (tagbody-env (make-instance 'lexical-exit-point-env + (label-set-name (gensym "label-set-")) + (tagbody-env (make-instance 'tagbody-env + :label-set-name label-set-name :uplink env :funobj funobj :save-esp-variable save-esp-variable @@ -642,8 +645,7 @@ (movitz-env-load-declarations `((muerte.cl::ignorable ,save-esp-variable ,lexical-catch-tag-variable)) tagbody-env nil) ;; First generate an assembly-level label for each tag. - (let* ((label-set-name (gensym "label-set-")) - (label-set (loop with label-id = 0 + (let* ((label-set (loop with label-id = 0 for tag-or-statement in (cdr form) as label = (when (or (symbolp tag-or-statement) (integerp tag-or-statement)) @@ -654,59 +656,60 @@ (setf (movitz-env-get tag-or-statement 'go-tag-label-id nil tagbody-env) (post-incf label-id)) and collect label)) - (tagbody-functional-p t) - (tagbody-code + (tagbody-codes (loop for tag-or-statement in (cdr form) -;;; when (and (symbolp tag-or-statement) -;;; (movitz-env-get tag-or-statement 'muerte::loop-tag nil tagbody-env)) -;;; collect '(:align :code :loop) if (or (symbolp tag-or-statement) ; Tagbody tags are "compiled" into.. (integerp tag-or-statement)) ; ..their assembly-level labels. collect (movitz-env-get tag-or-statement 'go-tag nil tagbody-env) - else append - (compiler-values-bind (&code code &functional-p functional-p) - (compiler-call #'compile-form - :defaults forward - :form tag-or-statement - :env tagbody-env - :result-mode :ignore) - (unless functional-p - (setf tagbody-functional-p nil)) - code)))) - (let ((maybe-store-esp-code - (when (and (not (eq result-mode :function)) - (operators-present-in-code-p tagbody-code '(:lexical-control-transfer) nil - :test (lambda (x) (eq tagbody-env (fifth x))))) - `((:init-lexvar ,save-esp-binding - :init-with-register :esp - :init-with-type t))))) - (if (not (code-uses-binding-p tagbody-code lexical-catch-tag-binding)) + else collect + (compiler-call #'compile-form + :defaults forward + :form tag-or-statement + :env tagbody-env + :result-mode :ignore)))) + (let* ((unlexical-target-p (some (lambda (code) + (when (listp code) + (code-uses-binding-p code save-esp-binding))) + tagbody-codes)) + (maybe-store-esp-code + (when (or unlexical-target-p + (some (lambda (code) + (when (listp code) + (operators-present-in-code-p code '(:lexical-control-transfer) nil + :test (lambda (x) + (eq tagbody-env (fifth x)))))) + tagbody-codes)) + `((:init-lexvar ,save-esp-binding + :init-with-register :esp + :init-with-type t))))) + (if (not unlexical-target-p) (compiler-values () - :code (append maybe-store-esp-code tagbody-code) - :functional-p tagbody-functional-p + :code (append maybe-store-esp-code + (loop for code in tagbody-codes + if (listp code) + append code + else append (list code))) :returns :nothing) - (let ((code (append maybe-store-esp-code - `((:declare-label-set ,label-set-name ,label-set) - (:leal ((:esi 8) :esp) :eax) ; generate some semi-unique value - (:leal ((:eax 2) :edi) :eax) ; with tag5. - (:init-lexvar ,lexical-catch-tag-binding - :init-with-register :eax - :init-with-type t)) - ;; catcher - `((:locally (:pushl (:edi (:edi-offset dynamic-env)))) + (let ((code (append `((:declare-label-set ,label-set-name ,label-set) + ;; catcher + (:locally (:pushl (:edi (:edi-offset dynamic-env)))) (:pushl ',label-set-name) (:pushl :eax) (:pushl :ebp) (:locally (:movl :esp (:edi (:edi-offset dynamic-env))))) - tagbody-code - `((:leal (:esp ,(+ -4 16)) :esp) - (:locally (:popl (:edi (:edi-offset dynamic-env))))) + maybe-store-esp-code + (loop for code in tagbody-codes + if (listp code) + append code + else append (list code '(:movl (:esp) :ebp))) + `((:movl (:esp 12) :edx) + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) + (:leal (:esp 16) :esp)) ))) (setf (num-specials tagbody-env) 1 (stack-used tagbody-env) 4) (compiler-values () :code code - :functional-p tagbody-functional-p :returns :nothing))))))) @@ -724,8 +727,31 @@ :code `((:lexical-control-transfer nil :nothing ,env ,tagbody-env ,label))) ;; Perform a lexical "throw" to the tag. Much like a regular throw, except ;; no values are transferred, and we step _into_ that dynamic env, not outside it. - (let ((label-id (movitz-env-get tag 'go-tag-label-id nil tagbody-env nil))) + (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) + #+ignore + (compiler-call #'compile-form-unprotected + :forward all + :form `(muerte::exact-throw ,(movitz-env-lexical-catch-tag-variable tagbody-env) + 0 nil)) + (compiler-values () + :returns :non-local-exit + :code `((:load-lexical ,save-esp-binding :edx) + (:movl :edx :eax) + (:globally (:call (:edi (:edi-offset dynamic-unwind-next)))) + (:jnc '(:sub-program () (:int 63))) + ;; 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 + (:jmp (:esi :eax + ,(* 4 label-id) ,(slot-offset 'movitz-funobj 'constant0))))) + #+ignore (compiler-values () :returns :non-local-exit :code (append (compiler-call #'compile-form

1 0

[movitz-cvs] CVS update: movitz/special-operators.lisp
by Frode Vatvedt Fjeld 07 Oct '04

07 Oct '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26254 Modified Files: special-operators.lisp Log Message: Minor edit, removed false comment. Date: Thu Oct 7 14:48:39 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.40 movitz/special-operators.lisp:1.41 --- movitz/special-operators.lisp:1.40 Tue Sep 21 15:01:23 2004 +++ movitz/special-operators.lisp Thu Oct 7 14:48:39 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.40 2004/09/21 13:01:23 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.41 2004/10/07 12:48:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1204,7 +1204,7 @@ (:globally (:call (:edi (:edi-offset dynamic-unwind-next)))) (:store-lexical ,next-continuation-step-binding :eax :type t) )))) - ;; now outside of m-v-prog1's cloak, with final dynamic-slot in ESP.. + ;; now outside of m-v-prog1's cloak, with final dynamic-slot in .. ;; ..unwind it and transfer control. ;; ;; * 12 dynamic-env uplink

1 0

[movitz-cvs] CVS update: movitz/losp/x86-pc/keyboard.lisp
by Frode Vatvedt Fjeld 07 Oct '04

07 Oct '04

Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv25449 Modified Files: keyboard.lisp Log Message: Tuning of *scan-codes*. Date: Thu Oct 7 14:45:10 2004 Author: ffjeld Index: movitz/losp/x86-pc/keyboard.lisp diff -u movitz/losp/x86-pc/keyboard.lisp:1.2 movitz/losp/x86-pc/keyboard.lisp:1.3 --- movitz/losp/x86-pc/keyboard.lisp:1.2 Mon Jan 19 12:23:52 2004 +++ movitz/losp/x86-pc/keyboard.lisp Thu Oct 7 14:45:07 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Mon Sep 24 16:04:12 2001 ;;;; -;;;; $Id: keyboard.lisp,v 1.2 2004/01/19 11:23:52 ffjeld Exp $ +;;;; $Id: keyboard.lisp,v 1.3 2004/10/07 12:45:07 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -37,7 +37,8 @@ #\D #\F #\G #\H #\J #\K #\L #\: ; #x20 #\" #\~ nil #\| #\Z #\X #\C #\V ; #x28 #\B #\N #\M #\< #\> #\? nil nil ; #x30 - nil nil nil nil nil nil nil nil)) ; #x38 + nil nil nil nil nil nil nil nil ; #x38 + nil nil nil nil nil :pause nil nil)) ; #x40 (defparameter *scan-codes* #(#\null #\esc #\1 #\2 #\3 #\4 #\5 #\6 ; #x00 @@ -50,7 +51,7 @@ #\b #\n #\m #\, #\. #\/ :shift-right #\esc ; #x30 :alt-left #\space :caps-lock :f1 :f2 :f3 :f4 :f5 ; #x38 - :f6 :f7 :f8 :f9 :f10 :num-lock nil nil ; #x40 + :f6 :f7 :f8 :f9 :f10 :break :scroll-lock nil ; #x40 nil nil nil nil nil nil nil nil ; #x48 nil :kp-ins nil :kp-del nil nil nil :f11 ; #x50 :f12 nil nil nil nil nil nil nil ; #x58 @@ -112,21 +113,6 @@ (io-port #x60 :unsigned-byte8)) (t (values (ldb (byte 7 0) first-code) (logbitp 7 first-code)))))) - -;;;(defmacro define-boolbit-accessor (name (bit-pos state-var) &body body) -;;; `(progn -;;; (defun ,name () -;;; (logbitp ,bit-pos ,state-var)) -;;; (defun (setf ,name) (value) -;;; (setf ,state-var -;;; (dpb (if value 1 0) (byte 1 ,bit-pos) ,state-var)) -;;; ,@body -;;; (logbitp ,bit-pos ,state-var)))) - - -;;;(define-boolbit-accessor qualifier-shift (0 *qualifier-state*)) -;;;(define-boolbit-accessor qualifier-ctrl (1 *qualifier-state*)) -;;;(define-boolbit-accessor qualifier-alt (2 *qualifier-state*)) (define-named-integer qualifier (:only-constants t) (0 shift)

1 0