movitz-cvs November 2004

movitz-cvs@common-lisp.net

1 participants
157 discussions

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

12 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8681 Modified Files: procfs-image.lisp Log Message: Somewhat improved backtrace output. Date: Fri Nov 12 15:41:10 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.19 movitz/procfs-image.lisp:1.20 --- movitz/procfs-image.lisp:1.19 Wed Sep 15 12:22:52 2004 +++ movitz/procfs-image.lisp Fri Nov 12 15:41:10 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.19 2004/09/15 10:22:52 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.20 2004/11/12 14:41:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -194,7 +194,7 @@ do (let ((movitz-name (funobj-name (stack-frame-funobj stack-frame)))) (typecase movitz-name (null - (write-string "?") + ;; (write-string "?") (let* ((eax (get-word (+ (* 4 (interrupt-frame-index :eax)) stack-frame))) (ebx (get-word (+ (* 4 (interrupt-frame-index :ebx)) stack-frame))) (ecx (get-word (+ (* 4 (interrupt-frame-index :ecx)) stack-frame))) @@ -205,12 +205,12 @@ (exception (get-word (+ (* 4 (interrupt-frame-index :exception-vector)) stack-frame)))) (format t "#x~X {EAX: #x~X, EBX: #x~X, ECX: #x~X, EDX: #x~X, EDI: #x~X, ESI: #x~X, EIP: #x~X, exception ~D}" - stack-frame + (truncate stack-frame 4) eax ebx ecx edx edi esi eip exception))) (movitz-symbol (let ((name (movitz-print movitz-name))) (when print-frames - (format t "~S " stack-frame)) + (format t "~S " (truncate stack-frame 4))) (when (string= name 'toplevel-function) (loop-finish)) (when reqs

1 0

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

12 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8644 Modified Files: special-operators-cl.lisp Log Message: Removed dead code. Date: Fri Nov 12 15:39:04 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.31 movitz/special-operators-cl.lisp:1.32 --- movitz/special-operators-cl.lisp:1.31 Thu Nov 11 20:26:06 2004 +++ movitz/special-operators-cl.lisp Fri Nov 12 15:39:04 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.31 2004/11/11 19:26:06 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.32 2004/11/12 14:39:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1130,10 +1130,7 @@ '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)))))))))) + (:leal (:esp (:edx 4)) :esp))))))) (define-special-operator labels (&all forward &form form &env env &funobj funobj) (destructuring-bind (labels-specs &body declarations-and-body)

1 0

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

11 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12842 Modified Files: packages.lisp Log Message: more symbols. Date: Thu Nov 11 20:29:08 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.38 movitz/packages.lisp:1.39 --- movitz/packages.lisp:1.38 Wed Sep 22 19:59:44 2004 +++ movitz/packages.lisp Thu Nov 11 20:29:08 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.38 2004/09/22 17:59:44 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.39 2004/11/11 19:29:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1084,7 +1084,7 @@ yes-or-no-p zerop)) -(defpackage #:muerte +(defpackage muerte (:use muerte.mop muerte.common-lisp) (:import-from common-lisp cl:nil) (:shadow get-setf-expansion) @@ -1128,7 +1128,8 @@ #:stack-frame-call-site #:stack-frame-ref #:check-stack-limit - #:interrupt-frame-ref + #:dit-frame-ref + #:interrupt-default-handler #:exception-handler #:*build-number* @@ -1186,6 +1187,9 @@ find-restart-from-context map-active-restarts with-basic-restart + + #:dynamic-variable-install + #:dynamic-variable-uninstall #:code-vector #:vector-u8

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-serv12811 Modified Files: interrupt.lisp Log Message: Include rtc-slot scratch2 when saving dynamic context. Date: Thu Nov 11 20:28:52 2004 Author: ffjeld Index: movitz/losp/muerte/interrupt.lisp diff -u movitz/losp/muerte/interrupt.lisp:1.30 movitz/losp/muerte/interrupt.lisp:1.31 --- movitz/losp/muerte/interrupt.lisp:1.30 Thu Nov 11 11:08:44 2004 +++ movitz/losp/muerte/interrupt.lisp Thu Nov 11 20:28:51 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.30 2004/11/11 10:08:44 ffjeld Exp $ +;;;; $Id: interrupt.lisp,v 1.31 2004/11/11 19:28:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -28,7 +28,7 @@ :atomically-continuation :raw-scratch0 :ecx :eax :edx :ebx :esi - :scratch1 + :scratch1 :scratch2 :debug0 :debug1 :tail-marker)) @@ -125,6 +125,7 @@ :key #'dit-frame-index) collect `(:pushl ,reg)) (:locally (:pushl (:edi (:edi-offset scratch1)))) + (:locally (:pushl (:edi (:edi-offset scratch2)))) (:locally (:movl (:edi (:edi-offset nursery-space)) :eax)) (:pushl :eax) ; debug0: nursery-space @@ -209,6 +210,8 @@ (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) (:movl (:ebp ,(dit-frame-offset :scratch1)) :eax) (:locally (:movl :eax (:edi (:edi-offset scratch1)))) + (:movl (:ebp ,(dit-frame-offset :scratch2)) :eax) + (:locally (:movl :eax (:edi (:edi-offset scratch2)))) ;; Load the DF flag from the interruptee before we restore ;; its register contents. @@ -266,9 +269,6 @@ (:int 63) ))) (do-it))) - - - (defun interrupt-default-handler (vector dit-frame) (declare (without-check-stack-limit))

1 0

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

11 Nov '04

Update of /project/movitz/cvsroot/movitz/losp In directory common-lisp.net:/tmp/cvs-serv12785 Modified Files: los0.lisp Log Message: *** empty log message *** Date: Thu Nov 11 20:28:18 2004 Author: ffjeld Index: movitz/losp/los0.lisp diff -u movitz/losp/los0.lisp:1.23 movitz/losp/los0.lisp:1.24 --- movitz/losp/los0.lisp:1.23 Mon Oct 11 15:51:55 2004 +++ movitz/losp/los0.lisp Thu Nov 11 20:28:18 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Fri Dec 1 18:08:32 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: los0.lisp,v 1.23 2004/10/11 13:51:55 ffjeld Exp $ +;;;; $Id: los0.lisp,v 1.24 2004/11/11 19:28:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -46,6 +46,29 @@ (in-package muerte.init) + +(defun test0 () + (ash 1 -1000000000000)) + +(defun test1 () + (unwind-protect 0 (the integer 1))) + +(defun test2 () + (funcall + (compile + nil + '(lambda (a) (declare (notinline > *)) + (declare (optimize (compilation-speed 0) (safety 2) (speed 2) (debug 0) (space 3))) + (catch 'ct1 (* a (throw 'ct1 (if (> 0) a 0)))))) + 5445205692802)) + +(defun test3 () + (loop for x below 2 count (not (not (typep x t))))) + +(defun test4 () + (let ((a 1)) (if (not (/= a 0)) a 0))) + + (defun test-floppy () (muerte.x86-pc::fd-start-disk) ; to initialize the controller and spin the drive up. (muerte.x86-pc::fd-cmd-seek 70) ; to seek to track 70. @@ -1095,6 +1118,14 @@ (:stc)) (values eax ebx ecx edx p1 p2))) +(defun null-primitive-function (x) + "This function is just like identity, except it also calls a null primitive function. +Can be used to measure the overhead of primitive function." + (with-inline-assembly (:returns :eax) + (:load-lexical (:lexical-binding x) :eax) + (% bytes 8 #xff #x97) ; (:call-local-pf ret-trampoline) + (% bytes 32 #.(bt:slot-offset 'movitz::movitz-run-time-context 'movitz::ret-trampoline)))) + (defun my-test-labels (x) (labels (#+ignore (p () (print x)) (q (y) (list x y))) @@ -1223,6 +1254,7 @@ (:ret))) (defun genesis () + (install-shallow-binding) (let ((extended-memsize 0)) ;; Find out how much extended memory we have (setf (io-port #x70 :unsigned-byte8) #x18) @@ -1295,9 +1327,14 @@ #+ignore (defun progntest () - (unwind-protect - (progn (print 'x) 'foo (error "bar")) - (print 'y))) + (prog () + (unwind-protect + (progn + (print 'x) + (go mumbo) + (error "bar")) + (print 'y)) + mumbo)) #+ignore (defun test-restart (x) @@ -1355,4 +1392,173 @@ (#\esc (break "Under the bridge.")) (#\e (error "this is an error!")))))))) + +(defparameter *write-barrier* nil) + +(defun show-writes () + (loop with num = (length *write-barrier*) + for i from 0 below num by 4 + initially (format t "~&Number of writes: ~D" (truncate num 4)) + do (format t "~&~D ~S: [~Z] Write to ~S: ~S." + i (aref *write-barrier* (+ i 3)) + (aref *write-barrier* i) + (aref *write-barrier* i) (aref *write-barrier* (+ i 2)))) + (values)) + +(defun es-test (&optional (barrier-size 1000)) + (setf *write-barrier* (or *write-barrier* + (make-array (* 4 barrier-size) :fill-pointer 0)) + (fill-pointer *write-barrier*) 0 + (exception-handler 13) #'general-protection-handler + (segment-register :es) 0) + (values)) + +(defun general-protection-handler (vector dit-frame) + (assert (= vector 13)) + (let ((eip (dit-frame-ref nil dit-frame :eip :unsigned-byte32))) + (assert (= #x26 (memref-int eip 0 0 :unsigned-byte8))) ; ES override prefix? + (let ((opcode (memref-int eip 1 0 :unsigned-byte8)) + (mod/rm (memref-int eip 2 0 :unsigned-byte8))) + (if (not (= #x89 opcode)) + (interrupt-default-handler vector dit-frame) + (let ((value (ecase (ldb (byte 3 3) mod/rm) + (0 (dit-frame-ref nil dit-frame :eax :lisp)) + (3 (dit-frame-ref nil dit-frame :ebx :lisp))))) + ;; If we return, don't execute with the ES override prefix: + (setf (dit-frame-ref nil dit-frame :eip :unsigned-byte32) (1+ eip)) + ;; If value isn't a pointer, we don't care.. + (when (typep value 'pointer) + (multiple-value-bind (object offset) + (case (logand mod/rm #xc7) + (#x40 ; (:movl <value> (:eax <disp8>)) + (values (dit-frame-ref nil dit-frame :eax) + (memref-int eip 3 0 :signed-byte8))) + (#x43 ; (:movl <value> (:ebx <disp8>)) + (values (dit-frame-ref nil dit-frame :ebx) + (memref-int eip 3 0 :signed-byte8))) + (#x44 ; the disp8/SIB case + (let ((sib (memref-int eip 3 0 :unsigned-byte8))) + (case sib + ((#x19 #x0b) + (values (dit-frame-ref nil dit-frame :ebx) + (+ (dit-frame-ref nil dit-frame :ecx :unsigned-byte8) + (memref-int eip 4 0 :signed-byte8)))) + ((#x1a) + (values (dit-frame-ref nil dit-frame :ebx) + (+ (dit-frame-ref nil dit-frame :edx :unsigned-byte8) + (memref-int eip 4 0 :signed-byte8)))))))) + (when (not object) + (setf (segment-register :es) (segment-register :ds)) + (break "[~S] With value ~S, unknown movl at ~S: ~S ~S ~S ~S" + dit-frame value eip + (memref-int eip 1 0 :unsigned-byte8) + (memref-int eip 2 0 :unsigned-byte8) + (memref-int eip 3 0 :unsigned-byte8) + (memref-int eip 4 0 :unsigned-byte8))) + (check-type object pointer) + (check-type offset fixnum) + (let ((write-barrier *write-barrier*) + (location (object-location object))) + (assert (not (location-in-object-p + (los0::space-other (%run-time-context-slot 'nursery-space)) + location)) () + "Write ~S to old-space at ~S." value location) + (unless (or (eq object write-barrier) + #+ignore + (location-in-object-p (%run-time-context-slot 'nursery-space) + location) + (location-in-object-p (%run-time-context-slot 'stack-vector) + location)) + (if (location-in-object-p (%run-time-context-slot 'nursery-space) + location) + (vector-push 'stack-actually write-barrier) + (vector-push object write-barrier)) + (vector-push offset write-barrier) + (vector-push value write-barrier) + (unless (vector-push eip write-barrier) + (setf (segment-register :es) (segment-register :ds)) + (break "Write-barrier is full: ~D" (length write-barrier)))))))))))) + +;;;;;;;;;;;;;;;;;; Shallow binding + +(define-primitive-function dynamic-variable-install-shallow () + "Install each dynamic binding entry between that in ESP (offset by 4 due to +the call to this primitive-function!) and current dynamic-env. +Preserve EDX." + (with-inline-assembly (:returns :nothing) + (:leal (:esp 4) :ecx) + install-loop + (:locally (:cmpl :ecx (:edi (:edi-offset dynamic-env)))) + (:je 'install-completed) + (:movl (:ecx 0) :eax) ; symbol + (:movl (:ecx 8) :ebx) ; new value + (:xchgl :ebx (:eax (:offset movitz-symbol value))) ; exchange new and old value + (:movl :ebx (:ecx 8)) + (:movl (:ecx 12) :ecx) + (:jmp 'install-loop) + install-completed + (:ret))) + +(define-primitive-function dynamic-variable-uninstall-shallow (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 be preserved." + (with-inline-assembly (:returns :nothing) + (:jc 'ecx-ok) + (:movl 1 :ecx) + ecx-ok + (:locally (:movl :ecx (:edi (:edi-offset raw-scratch0)))) + (:locally (:movl :eax (:edi (:edi-offset scratch1)))) + (:locally (:movl :ebx (:edi (:edi-offset scratch2)))) + + (:locally (:movl (:edi (:edi-offset dynamic-env)) :ecx)) + uninstall-loop + (:cmpl :edx :ecx) + (:je 'uninstall-completed) + (:movl (:ecx 0) :eax) ; symbol + (:movl (:ecx 8) :ebx) ; old value + (:movl :ebx (:eax (:offset movitz-symbol value))) ; reload old value + (:movl (:ecx 12) :ecx) + (:jmp 'uninstall-loop) + uninstall-completed + + (:locally (:movl (:edi (:edi-offset raw-scratch0)) :ecx)) + (:locally (:movl (:edi (:edi-offset scratch1)) :eax)) + (:locally (:movl (:edi (:edi-offset scratch2)) :ebx)) + (:stc) + (:ret))) + +(define-primitive-function dynamic-load-shallow (symbol) + "Load the dynamic value of SYMBOL into EAX." + (with-inline-assembly (:returns :multiple-values) + (:movl (:eax (:offset movitz-symbol value)) :eax) + (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax)) + (:je '(:sub-program (unbound) (:int 99))) + (:ret))) + +(define-primitive-function dynamic-load-unprotected-shallow (symbol) + "Load the dynamic value of SYMBOL into EAX." + (with-inline-assembly (:returns :multiple-values) + (:movl (:eax (:offset movitz-symbol value)) :eax) + (:ret))) + +(define-primitive-function dynamic-store-shallow (symbol value) + "Store VALUE (ebx) in the dynamic binding of SYMBOL (eax). + Preserves EBX and EAX." + (with-inline-assembly (:returns :multiple-values) + (:movl :ebx (:eax (:offset movitz-symbol value))) + (:ret))) + +(defun install-shallow-binding () + (macrolet ((install (slot function) + `(setf (%run-time-context-slot ',slot) (symbol-value ',function)))) + (install muerte:dynamic-variable-install dynamic-variable-install-shallow) + (install muerte:dynamic-variable-uninstall dynamic-variable-uninstall-shallow) + (install muerte::dynamic-store dynamic-store-shallow) + (install muerte::dynamic-load-unprotected dynamic-load-unprotected-shallow) + (install muerte::dynamic-load dynamic-load-shallow)) + (values)) + (genesis) +

1 0

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

11 Nov '04

Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12754 Modified Files: image.lisp Log Message: Replace dynamic-find-binding with dynamic-load-unprotected. Add rtc-slot scratch2. Date: Thu Nov 11 20:27:34 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.74 movitz/image.lisp:1.75 --- movitz/image.lisp:1.74 Wed Nov 10 18:34:40 2004 +++ movitz/image.lisp Thu Nov 11 20:27:33 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.74 2004/11/10 17:34:40 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.75 2004/11/11 19:27:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -161,7 +161,7 @@ :map-binary-write 'movitz-intern-code-vector :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) - (dynamic-find-binding + (dynamic-load-unprotected :map-binary-write 'movitz-intern-code-vector :binary-tag :primitive-function :map-binary-read-delayed 'movitz-word-code-vector @@ -476,6 +476,9 @@ :initform 0) (non-pointers-end :binary-type :label) ; ========= NON-POINTER-END ======= (scratch1 + :binary-type word + :initform 0) + (scratch2 :binary-type word :initform 0) (ret-trampoline

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.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-serv12690 Modified Files: primitive-functions.lisp Log Message: More improved implementation of dynamic binding protocol. Date: Thu Nov 11 20:26:12 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.50 movitz/losp/muerte/primitive-functions.lisp:1.51 --- movitz/losp/muerte/primitive-functions.lisp:1.50 Thu Nov 11 12:09:37 2004 +++ movitz/losp/muerte/primitive-functions.lisp Thu Nov 11 20:26:12 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.50 2004/11/11 11:09:37 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.51 2004/11/11 19:26:12 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -150,13 +150,14 @@ "Install each dynamic binding entry between that in ESP and current dynamic-env. Preserve EDX." (with-inline-assembly (:returns :nothing) + ;; Default binding strategy is naive deep binding, so this is a NOP. (: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." +and also EDX must be preserved." (with-inline-assembly (:returns :nothing) ;; Default binding strategy is naive deep binding, so this is a NOP. (:ret))) @@ -309,6 +310,10 @@ (:testl :edi :edi) ; clear ZF search-failed (:ret))) ; success: ZF=0, eax=value + + + +;;;;;;;;;;;;;; Heap allocation protocol (define-primitive-function get-cons-pointer () "Return in EAX the next object location with space for EAX words, with tag 6.

1 0

[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-serv12672 Modified Files: special-operators-cl.lisp Log Message: More improved implementation of dynamic binding protocol. Date: Thu Nov 11 20:26:06 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.30 movitz/special-operators-cl.lisp:1.31 --- movitz/special-operators-cl.lisp:1.30 Thu Nov 11 11:48:22 2004 +++ movitz/special-operators-cl.lisp Thu Nov 11 20:26:06 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.30 2004/11/11 10:48:22 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.31 2004/11/11 19:26:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -292,7 +292,11 @@ body-code (progn #+ignore (warn "recompile..") ; XXX (compile-body))) - (when (plusp (num-specials local-env)) + (when (and (plusp (num-specials local-env)) + (not (eq :non-local-exit body-returns))) + #+ignore + (warn "let spec ret: ~S, want: ~S ~S" + body-returns result-mode let-var-specs) `((:movl (:esp ,(+ -4 (* 16 (num-specials local-env)))) :edx) (:locally (:call (:edi ,(bt:slot-offset 'movitz-run-time-context 'dynamic-variable-uninstall)))) @@ -1248,7 +1252,7 @@ ;; Execute protected form.. (compiler-call #'compile-form :env unwind-protect-env - :with-stack-used t + :with-stack-used t ;; XXX Not really true, is it? :forward all :result-mode :multiple-values :form protected-form)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/symbols.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-serv12645 Modified Files: symbols.lisp Log Message: Rewrite boundp in terms of dynamic-load-unprotected. Date: Thu Nov 11 20:25:25 2004 Author: ffjeld Index: movitz/losp/muerte/symbols.lisp diff -u movitz/losp/muerte/symbols.lisp:1.22 movitz/losp/muerte/symbols.lisp:1.23 --- movitz/losp/muerte/symbols.lisp:1.22 Thu Oct 21 22:34:11 2004 +++ movitz/losp/muerte/symbols.lisp Thu Nov 11 20:25:25 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld <frodef(a)acm.org> ;;;; Created at: Tue Sep 4 23:55:41 2001 ;;;; -;;;; $Id: symbols.lisp,v 1.22 2004/10/21 20:34:11 ffjeld Exp $ +;;;; $Id: symbols.lisp,v 1.23 2004/11/11 19:25:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -52,12 +52,7 @@ (check-type symbol symbol) (with-inline-assembly (:returns :eax) (:compile-form (:result-mode :eax) symbol) - (:call-local-pf dynamic-find-binding) - (:jnc 'no-local-binding) - (:movl (:eax) :eax) - (:jmp 'done) - no-local-binding - (:movl (:eax (:offset movitz-symbol value)) :eax) + (:call-local-pf dynamic-load-unprotected) done)) (defun (setf symbol-value) (value symbol) @@ -128,7 +123,7 @@ (get-symbol-slot symbol package)) (defun boundp (symbol) - (boundp symbol)) + (compiler-macro-call boundp symbol)) (defun makunbound (symbol) (setf (symbol-value symbol)

1 0

[movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.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-serv12613 Modified Files: basic-macros.lisp Log Message: Rewrite boundp in terms of dynamic-load-unprotected. Date: Thu Nov 11 20:24:52 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.43 movitz/losp/muerte/basic-macros.lisp:1.44 --- movitz/losp/muerte/basic-macros.lisp:1.43 Thu Oct 21 22:33:57 2004 +++ movitz/losp/muerte/basic-macros.lisp Thu Nov 11 20:24:52 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: basic-macros.lisp,v 1.43 2004/10/21 20:33:57 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.44 2004/11/11 19:24:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1069,18 +1069,13 @@ (define-compiler-macro boundp (symbol) `(with-inline-assembly-case () - (do-case (t :boolean-cf=1 :labels (boundp-done)) + (do-case (t :boolean-zf=0 :labels (boundp-done)) (:compile-form (:result-mode :eax) ,symbol) - (:cmpl :edi :eax) - (:cmc) - (:je 'boundp-done) ; if ZF=1, then CF=1 after CMC - (:call-local-pf dynamic-find-binding) - (:jc 'boundp-done) - (:movl (:eax #.(bt:slot-offset 'movitz:movitz-symbol 'movitz::value)) :eax) - (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax)) - (:je 'boundp-done) - (:stc) - boundp-done))) + (:leal (:eax ,(- (movitz:tag :symbol))) :ecx) + (:testb 7 :cl) + (:jne '(:sub-program () (:int 66))) + (:call-local-pf dynamic-load-unprotected) + (:globally (:cmpl (:edi (:edi-offset unbound-value)) :eax))))) (defmacro define-global-variable (name init-form &optional docstring) "A global variable will be accessed by ignoring local bindings."

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 November 2004