movitz-cvs

movitz-cvs@common-lisp.net

2595 discussions

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

11 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18222 Modified Files: special-operators-cl.lisp Log Message: More about dynamic binding protocol: also call dynamic-variable-install at binding time. Date: Thu Nov 11 11:48:22 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.29 movitz/special-operators-cl.lisp:1.30 --- movitz/special-operators-cl.lisp:1.29 Wed Nov 10 18:34:47 2004 +++ movitz/special-operators-cl.lisp Thu Nov 11 11:48:22 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.29 2004/11/10 17:34:47 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.30 2004/11/11 10:48:22 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -285,7 +285,9 @@ :init-with-type ,(type-specifier-primary type)))))))) (t init-code))) (when (plusp (num-specials local-env)) - `((:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))) + `((:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context + 'dynamic-variable-install)))) + (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))) (if (not recompile-body-p) body-code (progn #+ignore (warn "recompile..") ; XXX @@ -1106,11 +1108,14 @@ (:jmp ',loop) ,no-more-symbols (:popl :eax) ; remove extra pre-pushed tail + (:movl :ecx :edx) + (:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context + 'dynamic-variable-install)))) (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))) ; install env ;; ecx = N/fixnum ;; (:shll 4 :ecx) ; ecx = 16*N ;; (:leal (:esp :ecx -4) :eax) ; eax = esp + 16*N - 4 - (:pushl :ecx) ; Save number of bindings. + (:pushl :edx) ; Save number of bindings. #+ignore (:pushl :eax))) ; push address of first binding's tail body-code (when (eq body-returns :push)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/interrupt.lisp
by Frode Vatvedt Fjeld 11 Nov '04

11 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15709 Modified Files: interrupt.lisp Log Message: *** empty log message *** Date: Thu Nov 11 11:08:45 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.29 movitz/losp/muerte/interrupt.lisp:1.30 --- movitz/losp/muerte/interrupt.lisp:1.29 Mon Oct 11 15:52:54 2004 +++ movitz/losp/muerte/interrupt.lisp Thu Nov 11 11:08:44 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Apr 7 01:50:03 2004 ;;;; -;;;; $Id: interrupt.lisp,v 1.29 2004/10/11 13:52:54 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.30 2004/11/11 10:08:44 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -62,6 +62,14 @@ (defun dit-frame-ref (stack frame reg &optional (type :lisp)) (stack-frame-ref stack frame (dit-frame-index reg) type)) +(define-compiler-macro (setf dit-frame-ref) (&whole form value stack frame reg + &optional (type :lisp) + &environment env) + (if (not (and (movitz:movitz-constantp stack env) + (eq nil (movitz:movitz-eval stack env)))) + form + `(setf (memref ,frame (dit-frame-offset ,reg) :type ,type) ,value))) + ;;;(defun (setf dit-frame-ref) (x reg type &optional (frame *last-dit-frame*)) ;;; (setf (memref frame (dit-frame-offset reg) 0 type) x)) @@ -117,7 +125,7 @@ :key #'dit-frame-index) collect `(:pushl ,reg)) (:locally (:pushl (:edi (:edi-offset scratch1)))) - + (:locally (:movl (:edi (:edi-offset nursery-space)) :eax)) (:pushl :eax) ; debug0: nursery-space (:pushl (:eax 2)) ; debug1: nursery-space's fresh-pointer @@ -126,9 +134,9 @@ ;; Do RET atomicification (:movl (:ebp ,(dit-frame-offset :eip)) :ecx) - (:cmpb ,(realpart (ia-x86:asm :ret)) (:ecx)) + ((:cs-override) :cmpb ,(realpart (ia-x86:asm :ret)) (:ecx)) (:jne 'not-at-ret-instruction) - (:locally (:movl (:edi (:edi-offset ret-trampoline)) :ecx)) + (:globally (:movl (:edi (:edi-offset ret-trampoline)) :ecx)) (:movl :ecx (:ebp ,(dit-frame-offset :eip))) not-at-ret-instruction @@ -259,6 +267,9 @@ ))) (do-it))) + + + (defun interrupt-default-handler (vector dit-frame) (declare (without-check-stack-limit)) (macrolet ((dereference (fixnum-address &optional (type :lisp)) @@ -277,7 +288,7 @@ (3 (break "Break instruction at ~@Z." $eip)) (4 (error "Primitive overflow assertion failed.")) (6 (error "Illegal instruction at ~@Z." $eip)) - (13 (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z" + (13 (error "General protection error. EIP=~@Z, error-code: #x~X, EAX: ~@Z, EBX: ~@Z, ECX: ~@Z" $eip (dit-frame-ref nil dit-frame :error-code :unsigned-byte32) $eax $ebx $ecx)) @@ -309,6 +320,7 @@ (stack (%run-time-context-slot 'movitz::stack-vector)) (real-bottom (- (object-location stack) 2)) (stack-left (- old-bottom real-bottom)) + (old-es (segment-register :es)) (old-dynamic-env (%run-time-context-slot 'dynamic-env)) (new-bottom (cond ((< stack-left 50) @@ -325,8 +337,9 @@ (unwind-protect (progn (setf (%run-time-context-slot 'stack-bottom) new-bottom - (%run-time-context-slot 'dynamic-env) 0) - (format *debug-io* "~&Stack-warning: Bumped stack-bottom by ~D to #x~X. Reset ENV.~%" + (%run-time-context-slot 'dynamic-env) 0 + (segment-register :es) (segment-register :ds)) + (format *debug-io* "~&Stack-warning: Bumped stack-bottom by ~D to #x~X. Reset ENV and ES.~%" (- old-bottom new-bottom) new-bottom) (break "Stack overload exception ~D at EIP=~@Z, ESP=~@Z, bottom=#x~X, ENV=#x~X." @@ -337,7 +350,8 @@ (format *debug-io* "~&Stack-warning: Resetting stack-bottom to #x~X.~%" old-bottom) (setf (%run-time-context-slot 'stack-bottom) old-bottom - (%run-time-context-slot 'dynamic-env) old-dynamic-env)))) + (%run-time-context-slot 'dynamic-env) old-dynamic-env + (segment-register :es) old-es)))) (69 (error "Not a function: ~S" (dereference $edx))) (70

1 0

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

10 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29348 Modified Files: compiler.lisp Log Message: *** empty log message *** Date: Wed Nov 10 18:37:21 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.103 movitz/compiler.lisp:1.104 --- movitz/compiler.lisp:1.103 Wed Nov 10 16:31:58 2004 +++ movitz/compiler.lisp Wed Nov 10 18:37:20 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.103 2004/11/10 15:31:58 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.104 2004/11/10 17:37:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -5742,7 +5742,9 @@ (stack-delta from-env to-env) (assert stack-distance) (assert (null unwind-protects) () - "Lexical unwind-protect not implemented.") + "Lexical unwind-protect not implemented, to-env: ~S." to-env) + (when (plusp num-dynamic-slots) + (warn "Lexical jump across ~D specials." num-dynamic-slots)) (cond ((and (eq t stack-distance) (zerop num-dynamic-slots))

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp
by Frode Vatvedt Fjeld 10 Nov '04

10 Nov '04

Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv29290 Modified Files: primitive-functions.lisp Log Message: Added support for pliant protocol for dynamic binding. Date: Wed Nov 10 18:34:51 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.47 movitz/losp/muerte/primitive-functions.lisp:1.48 --- movitz/losp/muerte/primitive-functions.lisp:1.47 Thu Oct 21 22:34:09 2004 +++ movitz/losp/muerte/primitive-functions.lisp Wed Nov 10 18:34:51 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.47 2004/10/21 20:34:09 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.48 2004/11/10 17:34:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -111,16 +111,22 @@ ;;; -32: car ... (define-primitive-function dynamic-unwind-next (dynamic-env) - "Locate the next unwind-protect entry between here and dynamic-env. + "Locate the next unwind-protect entry between here and dynamic-env/EAX. If no such entry is found, return (same) dynamic-env in EAX and CF=0. -Otherwise return the unwind-protect entry in EAX and CF=1. Preserve EDX." +Otherwise return the unwind-protect entry in EAX and CF=1. Preserve EDX. +Point is: Return the 'next step' in unwinding towards dynamic-env. +Note that it's an error if dynamic-env isn't in the current dynamic environment, +it's supposed to have been found by e.g. dynamic-locate-catch-tag." + ;; XXX: Not really sure if there's any point in the CF return value, + ;; because I don't think there's ever any need to know whether + ;; the returned entry is an unwind-protect or the actual target. (with-inline-assembly (:returns :nothing) (:locally (:bound (:edi (:edi-offset stack-bottom)) :eax)) (:globally (:movl (:edi (:edi-offset unwind-protect-tag)) :ebx)) (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) search-loop - (:jecxz '(:sub-program () (:halt) (:int 63))) ; XXX don't halt + (:jecxz '(:sub-program () (:int 63))) (:locally (:bound (:edi (:edi-offset stack-bottom)) :ecx)) (:cmpl :ecx :eax) @@ -129,6 +135,9 @@ (:cmpl :ebx (:ecx 4)) ; unwind-protect entry? (:je 'found-unwind-protect) + ;; We don't need to check for and uninstall dynamic binding entries, + ;; because uninstall is a NOP under naive deep binding. + (:movl (:ecx 12) :ecx) ; proceed search (:jmp 'search-loop) found-unwind-protect @@ -136,7 +145,20 @@ (:stc) found-dynamic-env (:ret))) - + +(define-primitive-function dynamic-variable-install () + "" + (with-inline-assembly (:returns :nothing) + (:ret))) + +(define-primitive-function dynamic-variable-uninstall (dynamic-env) + "Uninstall each dynamic binding between 'here' (i.e. the current +dynamic environment pointer) and the dynamic-env pointer provided in EDX. +This must be done without affecting 'current values'! (i.e. eax, ebx, ecx, or CF), +and also EDX must not be affected." + (with-inline-assembly (:returns :nothing) + ;; Default binding strategy is naive deep binding, so this is a NOP. + (:ret))) (define-primitive-function dynamic-locate-catch-tag (tag) "Search the dynamic environment for a catch slot matching <tag> in EAX.

1 0

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

10 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29269 Modified Files: special-operators-cl.lisp Log Message: Added support for pliant protocol for dynamic binding. Date: Wed Nov 10 18:34:47 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.28 movitz/special-operators-cl.lisp:1.29 --- movitz/special-operators-cl.lisp:1.28 Thu Oct 21 22:44:52 2004 +++ movitz/special-operators-cl.lisp Wed Nov 10 18:34: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.28 2004/10/21 20:44:52 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.29 2004/11/10 17:34:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -288,15 +288,14 @@ `((:locally (:movl :esp (:edi (:edi-offset dynamic-env)))))) (if (not recompile-body-p) body-code - (progn #+ignore (warn "recompile..") + (progn #+ignore (warn "recompile..") ; XXX (compile-body))) (when (plusp (num-specials local-env)) `((:movl (:esp ,(+ -4 (* 16 (num-specials local-env)))) :edx) + (:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context + 'dynamic-variable-uninstall)))) (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) - (:leal (:esp ,(* 16 (num-specials local-env))) :esp)) - #+ignore - `((:leal (:esp ,(+ -4 (* 16 (num-specials local-env)))) :esp) - (:locally (:popl (:edi (:edi-offset dynamic-env))))))))) + (:leal (:esp ,(* 16 (num-specials local-env))) :esp)))))) (compiler-values (body-values) :returns body-returns :producer (default-compiler-values-producer) @@ -1077,7 +1076,7 @@ values-form :eax funobj env) (with-labels (progv (no-more-symbols no-more-values loop zero-specials)) - `((:xorl :ecx :ecx) ; count number of bindings + `((:xorl :ecx :ecx) ; count number of bindings (fixnum) (:locally (:pushl (:edi (:edi-offset dynamic-env)))) ; first tail (:cmpl :edi :ebx) (:je '(:sub-program (,zero-specials) @@ -1086,7 +1085,7 @@ (:globally (:pushl (:edi (:edi-offset unbound-value)))) ; [[ binding tag ]] (:pushl :edi) ; binding name (:pushl :esp) - (:incl :ecx) + (:addl 4 :ecx) (:jmp ',no-more-symbols))) ,loop (:cmpl :edi :ebx) ; (endp symbols) @@ -1101,21 +1100,30 @@ (:globally (:pushl (:edi (:edi-offset unbound-value)))) ; [[ binding tag ]] (:pushl (:ebx -1)) ; push (car symbols) [[ binding name ]] (:movl (:ebx 3) :ebx) ; (pop symbols) - (:incw :cx) - (:jc '(:sub-program (too-many-symbols) (:int 71))) + (:addl 4 :ecx) + ;; (:jc '(:sub-program (too-many-symbols) (:int 71))) (:pushl :esp) ; push next tail (:jmp ',loop) ,no-more-symbols (:popl :eax) ; remove extra pre-pushed tail (:locally (:movl :esp (:edi (:edi-offset dynamic-env)))) ; install env - ;; ecx = N - (:shll 4 :ecx) ; ecx = 16*N - (:leal (:esp :ecx -4) :eax) ; eax = esp + 16*N - 4 - (:pushl :eax))) ; push address of first binding's tail + ;; ecx = N/fixnum + ;; (:shll 4 :ecx) ; ecx = 16*N + ;; (:leal (:esp :ecx -4) :eax) ; eax = esp + 16*N - 4 + (:pushl :ecx) ; Save number of bindings. + #+ignore (:pushl :eax))) ; push address of first binding's tail body-code (when (eq body-returns :push) `((:popl :eax))) ; glue :push => :eax - `((:popl :esp) ; pop address of first binding's tail + `((:movl (:esp) :edx) ; number of bindings + (:movl (:esp (:edx 4)) :edx) ; previous dynamic-env + (:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context + 'dynamic-variable-uninstall)))) + (:locally (:movl :edx (:edi (:edi-offset dynamic-env)))) + (:popl :edx) ; number of bindings + (:leal (:esp (:edx 4)) :esp)) + #+ignore + `((:popl :edx) ; pop address of first binding's tail (:locally (:popl (:edi (:edi-offset dynamic-env)))))))))) (define-special-operator labels (&all forward &form form &env env &funobj funobj)

1 0

[movitz-cvs] CVS update: movitz/image.lisp
by Frode Vatvedt Fjeld 10 Nov '04

10 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29251 Modified Files: image.lisp Log Message: Added support for pliant protocol for dynamic binding. Date: Wed Nov 10 18:34:40 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.73 movitz/image.lisp:1.74 --- movitz/image.lisp:1.73 Tue Nov 2 16:53:30 2004 +++ movitz/image.lisp Wed Nov 10 18:34:40 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: image.lisp,v 1.73 2004/11/02 15:53:30 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.74 2004/11/10 17:34:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -191,6 +191,16 @@ :binary-tag :primitive-function :map-binary-read-delayed 'movitz-word-code-vector :binary-type code-vector-word) + (dynamic-variable-install + :map-binary-write 'movitz-intern-code-vector + :binary-tag :primitive-function + :map-binary-read-delayed 'movitz-word-code-vector + :binary-type code-vector-word) + (dynamic-variable-uninstall + :map-binary-write 'movitz-intern-code-vector + :binary-tag :primitive-function + :map-binary-read-delayed 'movitz-word-code-vector + :binary-type code-vector-word) (assert-1arg :map-binary-write 'movitz-intern-code-vector :binary-tag :primitive-function @@ -435,7 +445,7 @@ (segment-descriptor-shifted-code ; 3: 1 MB shifted flat code segment :binary-type segment-descriptor :initform (make-segment-descriptor :base (image-cs-segment-base *image*) - :limit #xfff00 :type 10 :dpl 0 + :limit #xfff00 :type 14 :dpl 0 :flags '(s p d/b g))) (segment-descriptor-shifted-data ; 4: 1 MB shifted flat data segment :binary-type segment-descriptor

1 0

[movitz-cvs] CVS update: ia-x86/read.lisp
by Frode Vatvedt Fjeld 10 Nov '04

10 Nov '04

Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv22981 Modified Files: read.lisp Log Message: *** empty log message *** Date: Wed Nov 10 16:36:15 2004 Author: ffjeld Index: ia-x86/read.lisp diff -u ia-x86/read.lisp:1.7 ia-x86/read.lisp:1.8 --- ia-x86/read.lisp:1.7 Thu Sep 2 11:02:58 2004 +++ ia-x86/read.lisp Wed Nov 10 16:36:15 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jul 31 13:54:27 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: read.lisp,v 1.7 2004/09/02 09:02:58 ffjeld Exp $ +;;;; $Id: read.lisp,v 1.8 2004/11/10 15:36:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -304,7 +304,7 @@ (list* i (read-proglist-internal sub-programs :do-append-programs do-append-programs))) ;; nothing to insert other than i itself.. - (list i))) + (when i (list i)))) finally (assert (= (length *programs-to-append*) *already-appended*) () "Dangling sub-programs to append: ~S"

1 0

[movitz-cvs] CVS update: movitz/storage-types.lisp
by Frode Vatvedt Fjeld 10 Nov '04

10 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22939 Modified Files: storage-types.lisp Log Message: *** empty log message *** Date: Wed Nov 10 16:35:32 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.43 movitz/storage-types.lisp:1.44 --- movitz/storage-types.lisp:1.43 Thu Oct 21 22:42:51 2004 +++ movitz/storage-types.lisp Wed Nov 10 16:35:32 2004 @@ -9,14 +9,12 @@ ;;;; Created at: Sun Oct 22 00:22:43 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: storage-types.lisp,v 1.43 2004/10/21 20:42:51 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.44 2004/11/10 15:35:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (in-package movitz) -;; (defconstant +tag-other+ 6) - (define-unsigned lu64 8 :little-endian) (define-bitfield segment-descriptor (lu64) @@ -171,14 +169,15 @@ ;;; Fixnums (eval-when (:compile-toplevel :execute :load-toplevel) - (defconstant +movitz-fixnum-bits+ 30) - (defconstant +movitz-fixnum-shift+ (- 32 +movitz-fixnum-bits+)) - (defconstant +movitz-fixnum-factor+ (expt 2 +movitz-fixnum-shift+)) - (defconstant +movitz-fixnum-zmask+ (1- +movitz-fixnum-factor+)) - (defconstant +movitz-most-positive-fixnum+ (1- (expt 2 (1- +movitz-fixnum-bits+)))) - (defconstant +movitz-most-negative-fixnum+ (- (expt 2 (1- +movitz-fixnum-bits+)))) + (defparameter +movitz-fixnum-bits+ 30) + (defparameter +movitz-fixnum-shift+ (- 32 +movitz-fixnum-bits+)) + (defparameter +movitz-fixnum-factor+ (expt 2 +movitz-fixnum-shift+)) + (defparameter +movitz-fixnum-zmask+ (1- +movitz-fixnum-factor+)) + (defparameter +movitz-most-positive-fixnum+ (1- (expt 2 (1- +movitz-fixnum-bits+)))) + (defparameter +movitz-most-negative-fixnum+ (- (expt 2 (1- +movitz-fixnum-bits+)))) - (defparameter +other-type-offset+ -6)) + (defparameter +object-pointer-shift+ 0) + (defparameter +other-type-offset+ (- -6 +object-pointer-shift+))) (defun fixnum-integer (word) "For a Movitz word, that must be a fixnum, return the corresponding @@ -266,7 +265,7 @@ :map-binary-read-delayed 'movitz-word :initarg :cdr :accessor movitz-cdr)) - (:slot-align car -1)) + (:slot-align car #.(- -1 +object-pointer-shift+))) (defmethod movitz-object-offset ((obj movitz-cons)) 1)

1 0

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

10 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22897 Modified Files: compiler.lisp Log Message: *** empty log message *** Date: Wed Nov 10 16:31:58 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.102 movitz/compiler.lisp:1.103 --- movitz/compiler.lisp:1.102 Thu Oct 21 22:38:28 2004 +++ movitz/compiler.lisp Wed Nov 10 16:31:58 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.102 2004/10/21 20:38:28 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.103 2004/11/10 15:31:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -47,7 +47,7 @@ (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).") -(defparameter *compiler-nonlocal-lispval-read-segment-prefix* '(:fs-override) +(defparameter *compiler-nonlocal-lispval-read-segment-prefix* '() "Use this segment prefix when reading a lispval at (potentially) non-local locations.") @@ -55,6 +55,11 @@ "Use this segment prefix when writing a lispval at (potentially) non-local locations.") +(defparameter *compiler-use-cons-reader-segment-protocol-p* nil) + +(defparameter *compiler-cons-read-segment-prefix* '(:gs-override) + "Use this segment prefix for CAR and CDR, when using cons-reader protocol.") + (defvar *compiler-allow-untagged-word-bits* 0 "Allow (temporary) untagged values of this bit-size to exist, because the system ensures one way or another that there can be no pointers below @@ -6187,20 +6192,35 @@ (cond ((and binding-is-list-p (member location '(:eax :ebx :ecx :edx))) - `((:movl (,location ,op-offset) ,dst))) + `(,*compiler-nonlocal-lispval-read-segment-prefix* + (:movl (,location ,op-offset) ,dst))) (binding-is-list-p `(,@(make-load-lexical binding dst funobj nil frame-map) - (:movl (,dst ,op-offset) ,dst))) - ((eq location :ebx) - `((,*compiler-global-segment-prefix* - :call (:edi ,(global-constant-offset fast-op-ebx))) - ,@(when (not (eq dst :eax)) - `((:movl :eax ,dst))))) - (t `(,@(make-load-lexical binding :eax funobj nil frame-map) - (,*compiler-global-segment-prefix* - :call (:edi ,(global-constant-offset fast-op))) - ,@(when (not (eq dst :eax)) - `((:movl :eax ,dst)))))))))) + (,*compiler-nonlocal-lispval-read-segment-prefix* + :movl (,dst ,op-offset) ,dst))) + ((not *compiler-use-cons-reader-segment-protocol-p*) + (cond + ((eq location :ebx) + `((,*compiler-global-segment-prefix* + :call (:edi ,(global-constant-offset fast-op-ebx))) + ,@(when (not (eq dst :eax)) + `((:movl :eax ,dst))))) + (t `(,@(make-load-lexical binding :eax funobj nil frame-map) + (,*compiler-global-segment-prefix* + :call (:edi ,(global-constant-offset fast-op))) + ,@(when (not (eq dst :eax)) + `((:movl :eax ,dst))))))) + (t (cond + ((member location '(:ebx :ecx :edx)) + `((,(or *compiler-cons-read-segment-prefix* + *compiler-nonlocal-lispval-read-segment-prefix*) + :movl (:eax ,op-offset) ,dst))) + (t (append (make-load-lexical binding :eax funobj nil frame-map) + `((,(or *compiler-cons-read-segment-prefix* + *compiler-nonlocal-lispval-read-segment-prefix*) + :movl (:eax ,op-offset) ,dst))))))))))) + + ;;;;;;;;;;;;;;;;;; endp

1 0

[movitz-cvs] CVS update: movitz/compiler-types.lisp
by Frode Vatvedt Fjeld 10 Nov '04

10 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22865 Modified Files: compiler-types.lisp Log Message: *** empty log message *** Date: Wed Nov 10 16:31:41 2004 Author: ffjeld Index: movitz/compiler-types.lisp diff -u movitz/compiler-types.lisp:1.20 movitz/compiler-types.lisp:1.21 --- movitz/compiler-types.lisp:1.20 Wed Sep 15 12:19:06 2004 +++ movitz/compiler-types.lisp Wed Nov 10 16:31:41 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Wed Sep 10 00:40:07 2003 ;;;; -;;;; $Id: compiler-types.lisp,v 1.20 2004/09/15 10:19:06 ffjeld Exp $ +;;;; $Id: compiler-types.lisp,v 1.21 2004/11/10 15:31:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -667,7 +667,7 @@ (cdar intscope))) (list (movitz-read (caar intscope)))) ((and (null members) (null intscope)) - (warn "Not singleton, nulloton.")))) + (break "Not singleton, nulloton.")))) (defun movitz-subtypep (type0 type1) "Compile-time subtypep." @@ -678,11 +678,11 @@ (defun encoded-integer-types-add (code0 integer-range0 members0 include0 complement0 code1 integer-range1 members1 include1 complement1) "Return the integer type that can result from adding a member of type0 to a member of type1." - (declare (ignore members0 members1)) + ;; (declare (ignore members0 members1)) (cond - ((or include0 include1) + ((or include0 include1 members0 members1) ;; We can't know.. - 'integer) + 'number) ((or complement0 complement1) (break "adding complement types..?")) (t (let ((integer-range (numscope-plus (encoded-numscope code0 integer-range0)

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

movitz-cvs