[movitz-cvs] CVS update: movitz/losp/los0.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Thu Nov 11 19:28:19 UTC 2004
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)
+
More information about the Movitz-cvs
mailing list