From ffjeld at common-lisp.net Sun Feb 1 22:10:19 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 01 Feb 2004 17:10:19 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/ne2k.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv11834 Modified Files: ne2k.lisp Log Message: Changed to using %io-port-read/write-succession. Date: Sun Feb 1 17:10:18 2004 Author: ffjeld Index: movitz/losp/x86-pc/ne2k.lisp diff -u movitz/losp/x86-pc/ne2k.lisp:1.4 movitz/losp/x86-pc/ne2k.lisp:1.5 --- movitz/losp/x86-pc/ne2k.lisp:1.4 Mon Jan 19 06:23:52 2004 +++ movitz/losp/x86-pc/ne2k.lisp Sun Feb 1 17:10:17 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 17 15:16:00 2002 ;;;; -;;;; $Id: ne2k.lisp,v 1.4 2004/01/19 11:23:52 ffjeld Exp $ +;;;; $Id: ne2k.lisp,v 1.5 2004/02/01 22:10:17 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -66,7 +66,7 @@ (defun ne-x000-probe (&optional (io-base #x300)) "Probe for the presence of a NE2000 compatible card at IO-address io-base." (with-dp8390 (dp8390 io-base) - (let ((test-vector (copy-seq #(#xab #xba #x00 #xff #x55 #x99 #x01 #x23 #x45 #xde #xad #xbe #xef #x23)))) + (let ((test-vector #(#xabba #x00ff #x5599 #x0123 #x45de #xadbe #xef23))) (declare (dynamic-extent test-vector)) ;; NE1000 has RAM buffer located at 8192 ;; NE2000 has RAM buffer located at 16384 @@ -75,17 +75,15 @@ (dp8390 ($page0-write dcr)) ($data-config fifo-threshold-8-bytes loopback-off dma-16-bit)) - (with-dp8390-dma (dp8390 remote-write (length test-vector) 16384) - (io-port-write-sequence test-vector (+ io-base #x10) :unsigned-byte8 :16-bits)) + (with-dp8390-dma (dp8390 remote-write (* 2 (length test-vector)) 16384) + (loop with asic = (+ io-base #x10) + for x across test-vector + do (setf (io-port asic :unsigned-byte16) x))) (let ((mismatch nil)) - (with-dp8390-dma (dp8390 remote-read (length test-vector) 16384) - (dotimes (i (truncate (length test-vector) 2)) - (let ((nic-byte (io-port (+ io-base #x10) :unsigned-byte16))) - (unless (and (= (aref test-vector (* 2 i)) - (ldb (byte 8 0) nic-byte)) - (= (aref test-vector (1+ (* 2 i))) - (ldb (byte 8 8) nic-byte))) - (setf mismatch t))))) + (with-dp8390-dma (dp8390 remote-read (* 2 (length test-vector)) 16384) + (loop for x across test-vector + do (unless (= x (io-port (+ io-base #x10) :unsigned-byte16)) + (setf mismatch t)))) (unless mismatch 'ne2000))))) @@ -102,8 +100,10 @@ (let ((mac (make-array 6 :element-type 'muerte::u8))) (with-dp8390 (dp8390 io-base) (with-dp8390-dma (dp8390 remote-read 12 0) - (io-port-read-sequence mac (asic-io-base ne2000) - :unsigned-byte16 :16-bits))) + (dotimes (i 6) + (setf (aref mac i) + (ldb (byte 8 0) + (io-port (asic-io-base ne2000) :unsigned-byte16)))))) (setf (mac-address ne2000) mac)) ne2000)) @@ -117,6 +117,7 @@ (let ((asic-io (asic-io-base device)) (bnry (cached-bnry device)) (packet (or packet (make-array +max-ethernet-frame-size+ :element-type 'muerte::u8)))) + (check-type packet 'vector-u8) (with-dp8390 (dp8390 (io-base device)) (multiple-value-bind (packet-status next-bnry packet-length) (with-dp8390-dma (dp8390 remote-read 4 (* 256 bnry)) @@ -140,7 +141,7 @@ ((< (+ bnry (ash (1- packet-length) -8)) (ring-stop device)) (with-dp8390-dma (dp8390 remote-read packet-length (+ (* 256 bnry) 4)) - (io-port-read-sequence packet asic-io :unsigned-byte8 :16-bits :start start) + (%io-port-read-succession asic-io packet 2 start rx-end :16-bit) (when (oddp rx-end) (setf (aref packet (1- rx-end)) (ldb (byte 8 0) (io-port asic-io :unsigned-byte16))))) @@ -148,13 +149,11 @@ (cached-bnry device) next-bnry)) (t (let ((split-point (+ -4 (ash (- (ring-stop device) bnry) 8)))) (with-dp8390-dma (dp8390 remote-read split-point) - (io-port-read-sequence packet asic-io :unsigned-byte8 :16-bits - :start start :end (+ start split-point))) + (%io-port-read-succession asic-io packet 2 start (+ start split-point) :16-bit)) (with-dp8390-dma (dp8390 remote-read (- rx-end start split-point) (* 256 (ring-start device))) - (io-port-read-sequence packet asic-io :unsigned-byte8 :16-bits - :start (+ start split-point)) + (%io-port-read-succession asic-io packet 2 (+ start split-point) rx-end :16-bit) (when (oddp rx-end) (setf (aref packet (1- rx-end)) (ldb (byte 8 0) From ffjeld at common-lisp.net Sun Feb 1 22:16:27 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 01 Feb 2004 17:16:27 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/io-port.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv21480 Modified Files: io-port.lisp Log Message: Added 16-bit case to %io-port-read-succession. Date: Sun Feb 1 17:16:26 2004 Author: ffjeld Index: movitz/losp/muerte/io-port.lisp diff -u movitz/losp/muerte/io-port.lisp:1.5 movitz/losp/muerte/io-port.lisp:1.6 --- movitz/losp/muerte/io-port.lisp:1.5 Tue Jan 20 16:53:11 2004 +++ movitz/losp/muerte/io-port.lisp Sun Feb 1 17:16:26 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Mar 21 22:14:08 2001 ;;;; -;;;; $Id: io-port.lisp,v 1.5 2004/01/20 21:53:11 ffjeld Exp $ +;;;; $Id: io-port.lisp,v 1.6 2004/02/01 22:16:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -222,11 +222,40 @@ io-read-loop (:cmpl :ecx (:esp)) (:jbe 'end-io-read-loop) - (:inl :dx :eax) (:addl 4 :ecx) + (:inl :dx :eax) (:movl :eax (:ebx ,(+ offset -4) :ecx)) (:jmp 'io-read-loop) (:popl :eax) ; increment :esp, and put a lispval in :eax. + end-io-read-loop)))) + (:16-bit + (assert (= 4 movitz:+movitz-fixnum-factor+)) + (if (and t (<= 1 count 20)) + `(with-inline-assembly-case () + (do-case (t :ebx) + (:compile-two-forms (:edx :ebx) ,port ,object) + (:andl ,(cl:* #xffff movitz::+movitz-fixnum-factor+) :edx) + (:shrl ,movitz::+movitz-fixnum-shift+ :edx) + (:xorl :eax :eax) + ,@(loop for i from start below end + appending + `((:inw :dx :ax) + (:movw :ax (:ebx ,(+ offset (* 2 i)))))))) + `(with-inline-assembly-case () + (do-case (t :ebx :labels (io-read-loop end-io-read-loop not-fixnum)) + (:compile-two-forms (:edx :ebx) ,port ,object) + (:andl ,(cl:* #xffff movitz::+movitz-fixnum-factor+) :edx) + (:shrl ,movitz::+movitz-fixnum-shift+ :edx) + ;; (:pushl ,(cl:* movitz::+movitz-fixnum-factor+ end)) ; keep end in (:esp) + (:movl ,(cl:* 1 start) :ecx) + (:xorl :eax :eax) + io-read-loop + (:cmpl ,end :ecx) + (:ja 'end-io-read-loop) + (:addl 1 :ecx) + (:inw :dx :ax) + (:movw :ax (:ebx ,(+ offset -2) (:ecx 2))) + (:jmp 'io-read-loop) end-io-read-loop)))) (t (error "~S byte-size ~S not implemented." (car form) byte-size))))) ((and (movitz:movitz-constantp offset env)) From ffjeld at common-lisp.net Mon Feb 2 09:59:27 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 04:59:27 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7424 Modified Files: compiler.lisp Log Message: Added docstrings to some compiler defvars. Date: Mon Feb 2 04:59:26 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.4 movitz/compiler.lisp:1.5 --- movitz/compiler.lisp:1.4 Mon Jan 19 14:21:08 2004 +++ movitz/compiler.lisp Mon Feb 2 04:59:26 2004 @@ -8,25 +8,48 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.4 2004/01/19 19:21:08 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.5 2004/02/02 09:59:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ (in-package movitz) -(defvar *warn-function-change-p* t) -(defvar *explain-peephole-optimizations* nil) +(defvar *warn-function-change-p* t + "Emit a warning whenever a named function's code-vector changes size.") + +(defvar *compiler-do-optimize* t + "Apply the peephole optimizer to function code.") + +(defvar *explain-peephole-optimizations* nil + "Emit some cryptic information about which peephole optimization +heuristics that fire. Used for debugging the optimizer.") + +(defvar *compiler-use-cmov-p* nil + "Allow the compiler to emit CMOV instructions, making the code +incompatible with pre-pentium CPUs.") + +(defvar *compiler-auto-stack-checks-p* nil + "Make every compiled function check upon entry that the +stack-pointer is within bounds. Costs 3 code-bytes and a few cycles.") -(defvar *compiler-do-optimize* t) -(defvar *compiler-use-cmov-p* nil) -(defvar *compiler-auto-stack-checks-p* nil) (defvar *compiler-allow-transients* t "Allow the compiler to keep function arguments solely in registers. Hurst debugging, improves performance.") -(defvar *compiler-local-segment-prefix* '(:fs-override)) -(defvar *compiler-global-segment-prefix* nil) -(defvar *compiler-compile-eval-whens* t) -(defvar *compiler-compile-macro-expanders* t) + +(defvar *compiler-local-segment-prefix* '(:fs-override) + "Use these assembly-instruction prefixes when accessing the thread-local +run-time context.") + +(defvar *compiler-global-segment-prefix* nil + "Use these assembly-instruction prefixes when accessing the global +run-time context.") + +(defvar *compiler-compile-eval-whens* t + "When encountering (eval-when (:compile-toplevel) ), +compile, using the host compiler, the code rather than just using eval.") + +(defvar *compiler-compile-macro-expanders* t + "For macros of any kind, compile the macro-expanders using the host compiler.") (defvar *compiling-function-name*) (defvar muerte.cl:*compile-file-pathname* nil) From ffjeld at common-lisp.net Mon Feb 2 13:04:49 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 08:04:49 -0500 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12269 Modified Files: image.lisp Log Message: Improved movitz-print so it's more symmetric with movitz-read. Date: Mon Feb 2 08:04:49 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.3 movitz/image.lisp:1.4 --- movitz/image.lisp:1.3 Mon Jan 19 06:23:41 2004 +++ movitz/image.lisp Mon Feb 2 08:04:49 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.3 2004/01/19 11:23:41 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.4 2004/02/02 13:04:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1262,6 +1262,9 @@ (setf (gethash movitz-object (image-inverse-read-map-hash image)) lisp-object (gethash lisp-object (image-read-map-hash image)) movitz-object)) +(defmethod image-movitz-to-lisp-object ((image symbolic-image) movitz-object) + (gethash movitz-object (image-inverse-read-map-hash image))) + (defmacro with-movitz-read-context (options &body body) (declare (ignore options)) `(let ((*movitz-reader-clean-map* (if (boundp '*movitz-reader-clean-map*) @@ -1292,7 +1295,7 @@ (integer (make-movitz-fixnum expr)) (character (make-movitz-character expr)) (vector (make-movitz-vector (length expr) - :initial-contents (map 'vector #'movitz-read expr))) + :initial-contents (map 'vector #'movitz-read expr))) (cons (image-read-intern-constant *image* expr) #+ignore (if (eq '#0=#:error (ignore-errors (when (not (list-length expr)) '#0#))) @@ -1387,25 +1390,17 @@ ;;; "Printer" (defun movitz-print (expr) + "Find the host lisp object equivalent to the Movitz object expr." (etypecase expr (integer expr) (symbol expr) (cons (mapcar #'movitz-print expr)) ((or movitz-nil movitz-constant-block) nil) - (movitz-symbol - (intern (movitz-print (movitz-symbol-name expr)))) - (movitz-string - (map 'string #'identity - (movitz-vector-symbolic-data expr))) (movitz-fixnum (movitz-fixnum-value expr)) - (movitz-vector - (map 'vector #'movitz-print (movitz-vector-symbolic-data expr))) - (movitz-cons - (cons (movitz-print (movitz-car expr)) - (movitz-print (movitz-cdr expr)))))) - -;;; + (movitz-heap-object + (or (image-movitz-to-lisp-object *image* expr) + (error "Unknown Movitz object: ~S" expr))))) (defmethod make-toplevel-funobj ((*image* symbolic-image)) (let ((toplevel-code (loop for (funobj) in (image-load-time-funobjs *image*) From ffjeld at common-lisp.net Mon Feb 2 13:05:26 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 08:05:26 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv15362 Modified Files: compiler.lisp Log Message: Minor edits. Date: Mon Feb 2 08:05:25 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.5 movitz/compiler.lisp:1.6 --- movitz/compiler.lisp:1.5 Mon Feb 2 04:59:26 2004 +++ movitz/compiler.lisp Mon Feb 2 08:05:25 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.5 2004/02/02 09:59:26 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.6 2004/02/02 13:05:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -910,9 +910,9 @@ (values)) (defun movitz-compile-file-internal (path &optional (*default-load-priority* - (and (boundp '*default-load-priority*) - *default-load-priority* - (1+ *default-load-priority*)))) + (and (boundp '*default-load-priority*) + *default-load-priority* + (1+ *default-load-priority*)))) (declare (special *default-load-priority*)) (with-retries-until-true (retry "Restart Movitz compilation of ~S." path) (let* ((muerte.cl::*compile-file-pathname* path) @@ -921,11 +921,11 @@ :name (intern (format nil "file-~A" path) :muerte) :lambda-list (movitz-read nil))) (funobj-env (make-local-movitz-environment nil funobj - :type 'funobj-env - :declaration-context :funobj)) + :type 'funobj-env + :declaration-context :funobj)) (function-env (make-local-movitz-environment funobj-env funobj - :type 'function-env - :declaration-context :funobj)) + :type 'function-env + :declaration-context :funobj)) (file-code (with-compilation-unit () (with-open-file (stream path :direction :input) @@ -1792,7 +1792,7 @@ (defmethod print-object ((object binding) stream) (print-unreadable-object (object stream :type t :identity t) (when (slot-boundp object 'name) - (princ (binding-name object) stream)))) + (format stream "name: ~S" (binding-name object))))) (defclass constant-object-binding (binding) ((object @@ -4289,7 +4289,8 @@ :functional-p nil :modifies arguments-modifies :code (append arguments-code - (if (and t (eq operator (movitz-print (movitz-funobj-name funobj)))) ; recursive? + (if (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)))))) @@ -4677,6 +4678,8 @@ (:movb ,value ,(register32-to-low8 destination-register)))) (t `((:movl ,value ,destination-register))))) +(defparameter *prev-self-eval* nil) + (define-compiler compile-self-evaluating (&form form &result-mode result-mode &funobj funobj) "3.1.2.1.3 Self-Evaluating Objects" (let* ((object (or (quote-form-p form) form)) @@ -4684,7 +4687,7 @@ (funobj-env (funobj-env funobj)) (binding (or (cdr (assoc movitz-obj (movitz-environment-bindings funobj-env))) (let ((binding (make-instance 'constant-object-binding - :name movitz-obj + :name (gensym "self-eval-") :object movitz-obj))) (setf (binding-env binding) funobj-env) (push (cons movitz-obj binding) From ffjeld at common-lisp.net Mon Feb 2 13:06:06 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 08:06:06 -0500 Subject: [movitz-cvs] CVS update: movitz/movitz.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv17856 Modified Files: movitz.lisp Log Message: Added macro print-unreadable-movitz-object. Date: Mon Feb 2 08:06:06 2004 Author: ffjeld Index: movitz/movitz.lisp diff -u movitz/movitz.lisp:1.3 movitz/movitz.lisp:1.4 --- movitz/movitz.lisp:1.3 Fri Jan 16 07:02:05 2004 +++ movitz/movitz.lisp Mon Feb 2 08:06:06 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Oct 9 20:52:58 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: movitz.lisp,v 1.3 2004/01/16 12:02:05 ffjeld Exp $ +;;;; $Id: movitz.lisp,v 1.4 2004/02/02 13:06:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -29,6 +29,16 @@ (defvar *bq-level* 0) (defvar *default-image-init-file* #p"losp/los0.lisp") (defvar *default-image-file* #p"los0-image") + +(defmacro print-unreadable-movitz-object ((object stream &rest key-args) &body body) + "Just like print-unreadable-object, just adorn output so as to +make clear it's a Movitz object, with extra <..>" + (let ((stream-var (gensym "unreadable-movitz-stream-"))) + `(let ((,stream-var ,stream)) + (print-unreadable-object (,object ,stream-var , at key-args) + (write-char #\< ,stream-var) + , at body + (write-char #\> ,stream-var))))) (defmacro with-movitz-syntax (options &body body) (declare (ignore options)) From ffjeld at common-lisp.net Mon Feb 2 13:06:40 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 08:06:40 -0500 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv18305 Modified Files: packages.lisp Log Message: Added print-unreadable-movitz-object to movitz package. Date: Mon Feb 2 08:06:40 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.1.1.1 movitz/packages.lisp:1.2 --- movitz/packages.lisp:1.1.1.1 Tue Jan 13 06:04:59 2004 +++ movitz/packages.lisp Mon Feb 2 08:06:39 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.1.1.1 2004/01/13 11:04:59 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.2 2004/02/02 13:06:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1100,6 +1100,7 @@ simple-read-from-string print-word fixnump below + print-unreadable-movitz-object stack-ref with-each-dynamic-context @@ -1208,6 +1209,8 @@ #:io-delay #:io-port-read-sequence #:io-port-write-sequence + #:%io-port-read-succession + #:%io-port-write-succession #:with-io-register-syntax #:with-register-syntax #:cpu-id From ffjeld at common-lisp.net Mon Feb 2 13:09:26 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 08:09:26 -0500 Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5811 Modified Files: storage-types.lisp Log Message: Changed printing of Movitz vectors. Date: Mon Feb 2 08:09:26 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.2 movitz/storage-types.lisp:1.3 --- movitz/storage-types.lisp:1.2 Mon Jan 19 06:23:41 2004 +++ movitz/storage-types.lisp Mon Feb 2 08:09:26 2004 @@ -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.2 2004/01/19 11:23:41 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.3 2004/02/02 13:09:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -449,14 +449,15 @@ 8))) (defmethod print-object ((obj movitz-vector) stream) - (case (movitz-vector-element-type obj) - (:character - (format stream "#&~S" (map 'string #'identity + (print-unreadable-movitz-object (obj stream :type nil :identity t) + (case (movitz-vector-element-type obj) + (:character + (format stream "~S" (map 'string #'identity (movitz-vector-symbolic-data obj)))) - (t (format stream "#&[[ET:~A,NE:~A]~A]" - (movitz-vector-element-type obj) - (movitz-vector-num-elements obj) - (movitz-vector-symbolic-data obj)))) + (t (format stream "[ET:~A,NE:~A] ~A" + (movitz-vector-element-type obj) + (movitz-vector-num-elements obj) + (movitz-vector-symbolic-data obj))))) obj) (defmethod movitz-storage-alignment ((obj movitz-vector)) From ffjeld at common-lisp.net Mon Feb 2 13:27:27 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 08:27:27 -0500 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12267 Modified Files: image.lisp Log Message: Improved, hopefully, interaction between image-read-intern-constant and movitz-read. Date: Mon Feb 2 08:27:26 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.4 movitz/image.lisp:1.5 --- movitz/image.lisp:1.4 Mon Feb 2 08:04:49 2004 +++ movitz/image.lisp Mon Feb 2 08:27:26 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.4 2004/02/02 13:04:49 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.5 2004/02/02 13:27:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1238,19 +1238,11 @@ (string (or (gethash expr (image-string-constants *image*)) (setf (gethash expr (image-string-constants *image*)) - (make-movitz-string expr)))) + (movitz-read expr)))) (cons (or (gethash expr (image-cons-constants *image*)) (setf (gethash expr (image-cons-constants *image*)) - (if (eq '#0=#:error (ignore-errors (when (not (list-length expr)) '#0#))) - (multiple-value-bind (unfolded-expr cdr-index) - (unfold-circular-list expr) - (let ((result (movitz-read unfolded-expr))) - (setf (movitz-last-cdr result) - (movitz-nthcdr cdr-index result)) - result)) - (make-movitz-cons (movitz-read (car expr)) - (movitz-read (cdr expr))))))) + (movitz-read expr)))) (t (movitz-read expr)))) ;;; "Reader" @@ -1291,22 +1283,25 @@ (null *movitz-nil*) ((member t) (movitz-read 'muerte.cl:t)) (symbol (intern-movitz-symbol expr)) - (string (image-read-intern-constant *image* expr)) (integer (make-movitz-fixnum expr)) (character (make-movitz-character expr)) + (string (or (gethash expr (image-string-constants *image*)) + (setf (gethash expr (image-string-constants *image*)) + (make-movitz-string expr)))) (vector (make-movitz-vector (length expr) :initial-contents (map 'vector #'movitz-read expr))) (cons - (image-read-intern-constant *image* expr) - #+ignore (if (eq '#0=#:error (ignore-errors (when (not (list-length expr)) '#0#))) - (multiple-value-bind (unfolded-expr cdr-index) - (unfold-circular-list expr) - (let ((result (movitz-read unfolded-expr))) - (setf (movitz-last-cdr result) - (movitz-nthcdr cdr-index result)) - result)) - (make-movitz-cons (movitz-read (car expr)) - (movitz-read (cdr expr))))) + (or (gethash expr (image-cons-constants *image*)) + (setf (gethash expr (image-cons-constants *image*)) + (if (eq '#0=#:error (ignore-errors (when (not (list-length expr)) '#0#))) + (multiple-value-bind (unfolded-expr cdr-index) + (unfold-circular-list expr) + (let ((result (movitz-read unfolded-expr))) + (setf (movitz-last-cdr result) + (movitz-nthcdr cdr-index result)) + result)) + (make-movitz-cons (movitz-read (car expr)) + (movitz-read (cdr expr))))))) (hash-table (make-movitz-hash-table expr)) (structure-object From ffjeld at common-lisp.net Mon Feb 2 13:31:24 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 08:31:24 -0500 Subject: [movitz-cvs] CVS update: movitz/movitz-mode.el Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12447 Modified Files: movitz-mode.el Log Message: Various naming updates. Date: Mon Feb 2 08:31:23 2004 Author: ffjeld Index: movitz/movitz-mode.el diff -u movitz/movitz-mode.el:1.2 movitz/movitz-mode.el:1.3 --- movitz/movitz-mode.el:1.2 Thu Jan 15 12:37:11 2004 +++ movitz/movitz-mode.el Mon Feb 2 08:31:23 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Sep 27 18:12:17 2001 ;;;; -;;;; $Id: movitz-mode.el,v 1.2 2004/01/15 17:37:11 ffjeld Exp $ +;;;; $Id: movitz-mode.el,v 1.3 2004/02/02 13:31:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -108,7 +108,7 @@ (fi:eval-in-lisp "movitz::*bootblock-build*") display-shortcut) (call-process "/bin/sh" nil 0 nil "-c" - (format "DISPLAY=\"%s\" ~/tmp/bochs-cvs/bochs -nocp > bochs-parameters" + (format "DISPLAY=\"%s\" cd ~/clnet/movitz && ~/tmp/bochs-cvs/bochs -nocp > bochs-parameters" display-shortcut)))) (defun movitz-compile-file () @@ -220,7 +220,7 @@ (cl:char= #\\& (cl:char (cl:string x) 0)))) lambda-list))) (specializers (cl:mapcar #'muerte::find-specializer - (cl:mapcar (cl:lambda (x) (cl:if (cl:consp x) (cl:second x) 'los0.cl:t)) + (cl:mapcar (cl:lambda (x) (cl:if (cl:consp x) (cl:second x) 'muerte.cl:t)) specializing-lambda-list))) (method (muerte::movitz-find-method gf qualifiers specializers)) (funobj (muerte::movitz-slot-value method 'muerte::function)) @@ -258,7 +258,7 @@ (cl:let ((cl:*package* (cl:find-package :%s))) (cl:with-open-file (stream \"%s\" :direction :input) (cl:read stream)))) - :common-lisp :los0.common-lisp))))" + :common-lisp :muerte.common-lisp))))" fi:package fi:package tmp-file)) From ffjeld at common-lisp.net Mon Feb 2 13:40:37 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 08:40:37 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/basic-macros.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv7693 Modified Files: basic-macros.lisp Log Message: Made defconstant proclaim the variable-name special (on the host-side), avoiding compiler warnings when macro-expanders use it. Date: Mon Feb 2 08:40:37 2004 Author: ffjeld Index: movitz/losp/muerte/basic-macros.lisp diff -u movitz/losp/muerte/basic-macros.lisp:1.2 movitz/losp/muerte/basic-macros.lisp:1.3 --- movitz/losp/muerte/basic-macros.lisp:1.2 Mon Jan 19 06:23:46 2004 +++ movitz/losp/muerte/basic-macros.lisp Mon Feb 2 08:40:36 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.2 2004/01/19 11:23:46 ffjeld Exp $ +;;;; $Id: basic-macros.lisp,v 1.3 2004/02/02 13:40:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -464,6 +464,7 @@ ',name (movitz::movitz-eval ',name) movitz-value)) + (proclaim `(special ,movitz-name)) (setf (movitz::movitz-symbol-value movitz-symbol) (movitz::movitz-read movitz-value) (symbol-value movitz-name) movitz-value))) (declaim (muerte::constant-variable ,name)))) From ffjeld at common-lisp.net Mon Feb 2 13:41:53 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 08:41:53 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/dp8390.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv15284 Modified Files: dp8390.lisp Log Message: Added some information to dp8390 DMA protocol. Date: Mon Feb 2 08:41:53 2004 Author: ffjeld Index: movitz/losp/x86-pc/dp8390.lisp diff -u movitz/losp/x86-pc/dp8390.lisp:1.3 movitz/losp/x86-pc/dp8390.lisp:1.4 --- movitz/losp/x86-pc/dp8390.lisp:1.3 Mon Jan 19 06:23:52 2004 +++ movitz/losp/x86-pc/dp8390.lisp Mon Feb 2 08:41:52 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Sep 18 12:21:36 2002 ;;;; -;;;; $Id: dp8390.lisp,v 1.3 2004/01/19 11:23:52 ffjeld Exp $ +;;;; $Id: dp8390.lisp,v 1.4 2004/02/02 13:41:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -102,15 +102,15 @@ `((with-io-register-syntax (,var ,io-base-form) , at body))))) -(defun wait-for-dma-completion (io-base) +(defun wait-for-dma-completion (io-base &optional command) (with-dp8390 (dp8390 io-base) (setf (dp8390 ($page0-write cr)) ($command page-0 abort-complete)) (if (logbitp ($interrupt-status dma-complete) (dp8390 ($page0-read isr))) (setf (dp8390 ($page0-write isr)) (ash 1 ($interrupt-status dma-complete))) - (error "Incomplete dp8390 @ #x~X DMA: crda=#x~X." - io-base + (error "Incomplete dp8390~@[ ~A~] @ #x~X DMA: crda=#x~X." + command io-base (io-register8x2 dp8390 ($page0-read crda1) ($page0-read crda0))))) nil) @@ -131,7 +131,7 @@ `(setf (,dp8390-var ($page0-write cr)) ($command abort-complete)))) (initialize-dma ,dp8390-var ($command ,rdma-command) ,size ,address) , at body) - (wait-for-dma-completion ,dp8390-var))) + (wait-for-dma-completion ,dp8390-var ',rdma-command))) ;;; Utility functions From ffjeld at common-lisp.net Mon Feb 2 14:03:13 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 09:03:13 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/dp8390.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv32035 Modified Files: dp8390.lisp Log Message: Fixed with-dp8390-dma macro not to emit compiler warnings. Date: Mon Feb 2 09:03:13 2004 Author: ffjeld Index: movitz/losp/x86-pc/dp8390.lisp diff -u movitz/losp/x86-pc/dp8390.lisp:1.4 movitz/losp/x86-pc/dp8390.lisp:1.5 --- movitz/losp/x86-pc/dp8390.lisp:1.4 Mon Feb 2 08:41:52 2004 +++ movitz/losp/x86-pc/dp8390.lisp Mon Feb 2 09:03:13 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Sep 18 12:21:36 2002 ;;;; -;;;; $Id: dp8390.lisp,v 1.4 2004/02/02 13:41:52 ffjeld Exp $ +;;;; $Id: dp8390.lisp,v 1.5 2004/02/02 14:03:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -128,7 +128,7 @@ ;; Must be located inside with-dp8390. `(multiple-value-prog1 (macrolet ((dp8390-abort-dma () - `(setf (,dp8390-var ($page0-write cr)) ($command abort-complete)))) + `(setf (,',dp8390-var ($page0-write cr)) ($command abort-complete)))) (initialize-dma ,dp8390-var ($command ,rdma-command) ,size ,address) , at body) (wait-for-dma-completion ,dp8390-var ',rdma-command))) From ffjeld at common-lisp.net Mon Feb 2 14:52:24 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 09:52:24 -0500 Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29601 Modified Files: special-operators-cl.lisp Log Message: Have macrolet do the right thing with declarations and docstrings in expanders and bodies. Removes many host-compiler-warnings. Date: Mon Feb 2 09:52:24 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.3 movitz/special-operators-cl.lisp:1.4 --- movitz/special-operators-cl.lisp:1.3 Mon Jan 19 06:23:41 2004 +++ movitz/special-operators-cl.lisp Mon Feb 2 09:52:24 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.3 2004/01/19 11:23:41 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.4 2004/02/02 14:52:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -264,25 +264,30 @@ (destructuring-bind (macrolet-specs &body declarations-and-body) (cdr form) (multiple-value-bind (body declarations) - declarations-and-body + (parse-declarations-and-body declarations-and-body) (let ((local-env (make-local-movitz-environment env funobj - :type 'operator-env - :declarations declarations))) - (loop for (name local-lambda-list . local-body) in macrolet-specs + :type 'operator-env + :declarations declarations))) + (loop for (name local-lambda-list . local-body-decl-doc) in macrolet-specs as cl-local-lambda-list = (translate-program local-lambda-list :muerte.cl :cl) + as (local-body local-declarations) = + (multiple-value-list (parse-docstring-declarations-and-body local-body-decl-doc)) as cl-local-body = (translate-program local-body :muerte.cl :cl) + as cl-local-declarations = (translate-program local-declarations :muerte.cl :cl) as expander = `(lambda (form env) (declare (ignorable env)) (destructuring-bind ,cl-local-lambda-list (translate-program (rest form) :muerte.cl :cl) + (declare , at cl-local-declarations) (translate-program (block ,name (let () , at cl-local-body)) :cl :muerte.cl))) - do (movitz-env-add-binding local-env - (make-instance 'macro-binding - :name name - :expander (movitz-macro-expander-make-function expander - :name name - :type :macrolet)))) + do (movitz-env-add-binding + local-env + (make-instance 'macro-binding + :name name + :expander (movitz-macro-expander-make-function expander + :name name + :type :macrolet)))) (compiler-values-bind (&all body-values &code body-code) (compiler-call #'compile-implicit-progn :defaults forward From ffjeld at common-lisp.net Mon Feb 2 14:53:38 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 09:53:38 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv929 Modified Files: compiler.lisp Log Message: Rearranged movitz-macro-expander-make-function slightly, so it will generate gensym names (for compile) based on name and type. Date: Mon Feb 2 09:53:38 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.6 movitz/compiler.lisp:1.7 --- movitz/compiler.lisp:1.6 Mon Feb 2 08:05:25 2004 +++ movitz/compiler.lisp Mon Feb 2 09:53:38 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.6 2004/02/02 13:05:25 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.7 2004/02/02 14:53:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -132,14 +132,11 @@ (write (movitz-funobj-name object) :stream stream))) object) -(defun movitz-macro-expander-make-function (lambda-form - &key (name (gensym "macro-expander-")) - (type :unknown)) +(defun movitz-macro-expander-make-function (lambda-form &key name (type :unknown)) "Make a lambda-form that is a macro-expander into a proper function." - (declare (ignore type)) - (check-type name symbol) (if *compiler-compile-macro-expanders* - (compile name lambda-form) + (compile (gensym (format nil "~A-expander-~@[~A-~]" type name)) + lambda-form) (coerce lambda-form 'function))) (defun make-compiled-funobj (&rest args) From ffjeld at common-lisp.net Mon Feb 2 14:54:30 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 09:54:30 -0500 Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv3520 Modified Files: special-operators.lisp Log Message: Altered a call to movitz-macro-expander-make-function in accordance with new naming scheme. Date: Mon Feb 2 09:54:29 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.3 movitz/special-operators.lisp:1.4 --- movitz/special-operators.lisp:1.3 Fri Jan 16 14:25:04 2004 +++ movitz/special-operators.lisp Mon Feb 2 09:54:29 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.3 2004/01/16 19:25:04 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.4 2004/02/02 14:54:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -442,7 +442,7 @@ (translate-program ,expansion-var :cl :muerte.cl))))))) (setf (movitz-compiler-macro-function operator-name nil) (movitz-macro-expander-make-function expander - :name (gensym (format nil "~A-compiler-macro-" name)) + :name name :type :compiler-macro)))))))) (compiler-values ())) From ffjeld at common-lisp.net Mon Feb 2 14:55:08 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 09:55:08 -0500 Subject: [movitz-cvs] CVS update: movitz/los0-image Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12306 Removed Files: los0-image Log Message: Removed from CVS, not supposed to be here. Date: Mon Feb 2 09:55:07 2004 Author: ffjeld From ffjeld at common-lisp.net Mon Feb 2 14:55:32 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 09:55:32 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/simple-streams.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv25344 Modified Files: simple-streams.lisp Log Message: Minor edits. Date: Mon Feb 2 09:55:32 2004 Author: ffjeld Index: movitz/losp/muerte/simple-streams.lisp diff -u movitz/losp/muerte/simple-streams.lisp:1.2 movitz/losp/muerte/simple-streams.lisp:1.3 --- movitz/losp/muerte/simple-streams.lisp:1.2 Mon Jan 19 06:23:47 2004 +++ movitz/losp/muerte/simple-streams.lisp Mon Feb 2 09:55:32 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Aug 29 13:39:43 2003 ;;;; -;;;; $Id: simple-streams.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $ +;;;; $Id: simple-streams.lisp,v 1.3 2004/02/02 14:55:32 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -70,23 +70,23 @@ (type simple-vector ,slots-var) (ignorable ,slots-var)) (macrolet ((sm (slot-name stream) - ;; (declare (ignore stream)) - `(slot-value ,stream ',slot-name) + (declare (ignore stream)) + `(slot-value ,',stream-var ',slot-name) #+ignore `(svref%unsafe ,',slots-var ,(slot-location ,(movitz-find-class class-name) slot-name))) (add-stream-instance-flags (stream &rest flags) - ;; (declare (ignore stream)) + (declare (ignore stream)) `(setf (sm %flags ,',stream-var) (logior (sm %flags ,',stream-var) ,(%flags flags)))) (remove-stream-instance-flags (stream &rest flags) - ;; (declare (ignore stream)) + (declare (ignore stream)) `(setf (sm %flags ,',stream-var) (logandc2 (sm %flags ,',stream-var) ,(%flags flags)))) (any-stream-instance-flags (stream &rest flags) - ;; (declare (ignore stream)) + (declare (ignore stream)) `(not (zerop (logand (sm %flags ,',stream-var) ,(%flags flags)))))) , at body))) From ffjeld at common-lisp.net Mon Feb 2 14:57:35 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 09:57:35 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/ne2k.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv938 Modified Files: ne2k.lisp Log Message: Minor edit. Date: Mon Feb 2 09:57:35 2004 Author: ffjeld Index: movitz/losp/x86-pc/ne2k.lisp diff -u movitz/losp/x86-pc/ne2k.lisp:1.5 movitz/losp/x86-pc/ne2k.lisp:1.6 --- movitz/losp/x86-pc/ne2k.lisp:1.5 Sun Feb 1 17:10:17 2004 +++ movitz/losp/x86-pc/ne2k.lisp Mon Feb 2 09:57:34 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 17 15:16:00 2002 ;;;; -;;;; $Id: ne2k.lisp,v 1.5 2004/02/01 22:10:17 ffjeld Exp $ +;;;; $Id: ne2k.lisp,v 1.6 2004/02/02 14:57:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -67,10 +67,9 @@ "Probe for the presence of a NE2000 compatible card at IO-address io-base." (with-dp8390 (dp8390 io-base) (let ((test-vector #(#xabba #x00ff #x5599 #x0123 #x45de #xadbe #xef23))) - (declare (dynamic-extent test-vector)) ;; NE1000 has RAM buffer located at 8192 ;; NE2000 has RAM buffer located at 16384 - ;; We have detected NE2000, check if 16-bit access works: + ;; Check if 16-bit access works to NE2000 RAM works: (setf (dp8390 ($page0-write cr)) ($command page-0) (dp8390 ($page0-write dcr)) ($data-config fifo-threshold-8-bytes loopback-off From ffjeld at common-lisp.net Mon Feb 2 21:59:28 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 02 Feb 2004 16:59:28 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/x86-pc/ne2k.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/x86-pc In directory common-lisp.net:/tmp/cvs-serv8416 Modified Files: ne2k.lisp Log Message: More updating related to using %io-port-read/write-succession. I hope it still works. Date: Mon Feb 2 16:59:27 2004 Author: ffjeld Index: movitz/losp/x86-pc/ne2k.lisp diff -u movitz/losp/x86-pc/ne2k.lisp:1.6 movitz/losp/x86-pc/ne2k.lisp:1.7 --- movitz/losp/x86-pc/ne2k.lisp:1.6 Mon Feb 2 09:57:34 2004 +++ movitz/losp/x86-pc/ne2k.lisp Mon Feb 2 16:59:27 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Sep 17 15:16:00 2002 ;;;; -;;;; $Id: ne2k.lisp,v 1.6 2004/02/02 14:57:34 ffjeld Exp $ +;;;; $Id: ne2k.lisp,v 1.7 2004/02/02 21:59:27 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -112,8 +112,10 @@ (defun pop-ringbuffer (device &optional packet (start 0)) "When the ring-buffer isn't empty, fetch the next packet." + (assert (evenp start)) (unless (ring-empty-p device) - (let ((asic-io (asic-io-base device)) + (let ((io-start (truncate start 2)) + (asic-io (asic-io-base device)) (bnry (cached-bnry device)) (packet (or packet (make-array +max-ethernet-frame-size+ :element-type 'muerte::u8)))) (check-type packet 'vector-u8) @@ -132,7 +134,8 @@ (< next-bnry (ring-stop device))) () "Illegal next-bnry #x~X at #x~X, length ~D." next-bnry bnry packet-length) - (let ((rx-end (+ start packet-length))) + (let* ((rx-end (+ start packet-length)) + (io-end (truncate (1+ rx-end)))) (declare (type (unsigned-byte 16) rx-end)) (assert (evenp start)) (setf (fill-pointer packet) rx-end) @@ -140,23 +143,18 @@ ((< (+ bnry (ash (1- packet-length) -8)) (ring-stop device)) (with-dp8390-dma (dp8390 remote-read packet-length (+ (* 256 bnry) 4)) - (%io-port-read-succession asic-io packet 2 start rx-end :16-bit) - (when (oddp rx-end) - (setf (aref packet (1- rx-end)) - (ldb (byte 8 0) (io-port asic-io :unsigned-byte16))))) + (%io-port-read-succession asic-io packet 2 io-start io-end :16-bit)) (setf (dp8390 ($page0-write bnry)) next-bnry (cached-bnry device) next-bnry)) - (t (let ((split-point (+ -4 (ash (- (ring-stop device) bnry) 8)))) + (t (let* ((split-point (+ -4 (ash (- (ring-stop device) bnry) 8))) + (io-split-point (truncate split-point 2))) (with-dp8390-dma (dp8390 remote-read split-point) - (%io-port-read-succession asic-io packet 2 start (+ start split-point) :16-bit)) + (%io-port-read-succession asic-io packet 2 + io-start (+ io-start io-split-point) :16-bit)) (with-dp8390-dma (dp8390 remote-read (- rx-end start split-point) (* 256 (ring-start device))) - (%io-port-read-succession asic-io packet 2 (+ start split-point) rx-end :16-bit) - (when (oddp rx-end) - (setf (aref packet (1- rx-end)) - (ldb (byte 8 0) - (io-port asic-io :unsigned-byte16))))) + (%io-port-read-succession asic-io packet 2 (+ io-start io-split-point) io-end :16-bit)) (setf (dp8390 ($page0-write bnry)) next-bnry (cached-bnry device) next-bnry) #+ignore (warn "split-point: ~D/~D bnry: ~S" @@ -213,11 +211,8 @@ (let ((packet-length (- end start))) (with-dp8390-dma (dp8390 remote-write packet-length (ash (transmit-buffer device) 8)) - (io-port-write-sequence packet (asic-io-base device) :unsigned-byte8 :16-bits - :start start :end end) - (when (oddp packet-length) - (setf (io-port (asic-io-base device) :unsigned-byte16) - (aref packet (1- end))))) + (%io-port-write-succession (asic-io-base device) packet 2 + (truncate start 2) (truncate (1+ end) 2) :16-bit)) (loop while (logbitp ($command-bit transmit) (dp8390 ($page0-read cr)))) (setf (io-register8x2 dp8390 ($page0-write tbcr1) ($page0-write tbcr0)) packet-length (dp8390 ($page0-write cr)) ($command transmit start abort-complete)) From ffjeld at common-lisp.net Tue Feb 3 09:57:49 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 03 Feb 2004 04:57:49 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/lists.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv32056 Modified Files: lists.lisp Log Message: Fixed typo in (setf getf). Date: Tue Feb 3 04:57:49 2004 Author: ffjeld Index: movitz/losp/muerte/lists.lisp diff -u movitz/losp/muerte/lists.lisp:1.2 movitz/losp/muerte/lists.lisp:1.3 --- movitz/losp/muerte/lists.lisp:1.2 Mon Jan 19 06:23:46 2004 +++ movitz/losp/muerte/lists.lisp Tue Feb 3 04:57:49 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Tue Dec 5 18:40:11 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: lists.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $ +;;;; $Id: lists.lisp,v 1.3 2004/02/03 09:57:49 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -269,7 +269,7 @@ (let ((new-value (gensym)) (indicator-var (gensym)) (default-var (if default (gensym)))) - (values `(, at temps ,indicator-var ,@(if default (list def-temp))) + (values `(, at temps ,indicator-var ,@(if default (list default-var))) `(, at values ,indicator ,@(if default (list default))) `(,new-value) `(let ((,(car stores) (putf ,getter ,indicator-var ,new-value))) From ffjeld at common-lisp.net Tue Feb 3 10:03:00 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 03 Feb 2004 05:03:00 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/io-port.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5989 Modified Files: io-port.lisp Log Message: Removed old io-port-read/write-sequence. Date: Tue Feb 3 05:02:59 2004 Author: ffjeld Index: movitz/losp/muerte/io-port.lisp diff -u movitz/losp/muerte/io-port.lisp:1.6 movitz/losp/muerte/io-port.lisp:1.7 --- movitz/losp/muerte/io-port.lisp:1.6 Sun Feb 1 17:16:26 2004 +++ movitz/losp/muerte/io-port.lisp Tue Feb 3 05:02:59 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Mar 21 22:14:08 2001 ;;;; -;;;; $Id: io-port.lisp,v 1.6 2004/02/01 22:16:26 ffjeld Exp $ +;;;; $Id: io-port.lisp,v 1.7 2004/02/03 10:02:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -480,203 +480,4 @@ (:32-bit (%io-port-write-succession port object 2 start end :32-bit)) (t (error "Unknown byte-size ~S." byte-size)))) - - -(defun io-port-read-sequence (sequence port type transfer-unit &key (start 0) end) - (etypecase sequence - ((or string muerte::vector-u8) - (unless end (setf end (length sequence))) - (let ((size (- end start))) - (assert (<= 0 start end (length sequence)) (start end) - "io-port-read-sequence out of bounds: ~D - ~D into ~D / ~D" start end (length sequence) (array-dimension sequence 0)) - (ecase type - (:unsigned-byte8 - (ecase transfer-unit - (:8-bits - ;; one-to-one - (with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :edx) port) - (:shrl #.movitz::+movitz-fixnum-shift+ :edx) - (:compile-form (:result-mode :ecx) start) - (:compile-form (:result-mode :ebx) sequence) - (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - (:addl #.(bt:slot-offset 'movitz::movitz-vector 'movitz::data) :ebx) - (:addl :ecx :ebx) - (:compile-form (:result-mode :ecx) size) - (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - (:xorl :eax :eax) - (:jecxz 'read8-done) - read8-loop - (:inb :dx :al) - (:movb :al (:ebx)) - (:incl :ebx) - (:decl :ecx) - (:jnz 'read8-loop) - read8-done)) - (:16-bits - ;; each 16-bits IOW maps to two u2 - (with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :edx) port) - (:shrl #.movitz::+movitz-fixnum-shift+ :edx) - (:compile-form (:result-mode :ecx) start) - (:compile-form (:result-mode :ebx) sequence) - (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - (:addl #.(bt:slot-offset 'movitz::movitz-vector 'movitz::data) :ebx) - (:addl :ecx :ebx) - (:compile-form (:result-mode :ecx) size) - (:shrl #.(cl:1+ movitz::+movitz-fixnum-shift+) :ecx) - (:xorl :eax :eax) - (:jecxz 'read16-done) - read16-loop - (:inw :dx :ax) - (:movw :ax (:ebx)) - (:addl 2 :ebx) - (:decl :ecx) - (:jnz 'read16-loop) - read16-done)))) - (:unsigned-byte16 - (ecase transfer-unit - (:16-bits - ;; 16-bit io-port squeezed into 8 bits.. - (with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :edx) port) - (:shrl #.movitz::+movitz-fixnum-shift+ :edx) - (:compile-form (:result-mode :ebx) sequence) - (:addl #.(bt:slot-offset 'movitz::movitz-vector 'movitz::data) :ebx) - (:compile-form (:result-mode :ecx) start) - (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - (:addl :ecx :ebx) - (:compile-form (:result-mode :ecx) size) - (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - (:xorl :eax :eax) - (:jecxz 'read16-8-done) - read16-8-loop - (:inw :dx :ax) - (:movb :al (:ebx)) - (:incl :ebx) - (:decl :ecx) - (:jnz 'read16-8-loop) - read16-8-done))))))) - (vector - (unless end (setf end (length sequence))) - (let ((size (- end start))) - (assert (<= 0 start end (length sequence)) (start end) - "io-port-read-sequence out of bounds.") - (ecase type - (:unsigned-byte8 - (ecase transfer-unit - (:8-bits - (dotimes (i size) - (setf (aref sequence (+ start i)) - (io-port port :unsigned-byte8)))) - (:16-bits - (dotimes (i (truncate size 2)) - (let ((byte (io-port port :unsigned-byte16))) - (setf (aref sequence (+ start (* 2 i))) (ldb (byte 8 0) byte) ; little endian.. - (aref sequence (+ start (* 2 i) 1)) (ldb (byte 8 8) byte)))))))))) - (list - (when sequence - (let ((start-cons (nthcdr start sequence))) - (assert start-cons (sequence) - "Sequence start ~D out of range: ~S" start sequence) - (ecase type - (:unsigned-byte8 - (ecase transfer-unit - (:8-bits - (if (not end) - (loop for p on start-cons - do (setf (car p) (io-port port :unsigned-byte8))) - (loop for i upfrom start below end as p on (nthcdr start sequence) - do (setf (car p) (io-port port :unsigned-byte8)) - finally (assert (= i end) (end) - "Sequence end ~D out of range: ~S" end sequence)))) - (:16-bits - (if (not end) - (loop for p on start-cons by #'cddr - do (let ((byte (io-port port :unsigned-byte16))) - (setf (car p) (ldb (byte 8 0) byte) ; little endian.. - (cadr p) (ldb (byte 8 8) byte)))) - (loop for i upfrom start below end by 2 as p on (nthcdr start sequence) by #'cddr - do (let ((byte (io-port port :unsigned-byte16))) - (setf (car p) (ldb (byte 8 0) byte) ; little endian.. - (cadr p) (ldb (byte 8 8) byte))) - finally (assert (= i end) (end) - "Sequence end ~D out of range: ~S" end sequence))))))))))) - sequence) - -(defun io-port-write-sequence (sequence port type transfer-unit &key (start 0) end) - (etypecase sequence - ((or string muerte::vector-u8) - (unless end (setf end (length sequence))) - (let ((size (- end start))) - (assert (<= 0 start end (length sequence)) (start end) - "io-port-write-sequence out of bounds.") - (ecase type - ((:unsigned-byte8) - (ecase (or transfer-unit :8-bits) - (:8-bits - ;; one-to-one - (with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :edx) port) - (:shrl #.movitz::+movitz-fixnum-shift+ :edx) - (:compile-form (:result-mode :ebx) sequence) - (:compile-form (:result-mode :ecx) start) - (:addl #.(bt:slot-offset 'movitz::movitz-vector 'movitz::data) :ebx) - (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - (:addl :ecx :ebx) - (:compile-form (:result-mode :ecx) size) - (:xorl :eax :eax) - (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - (:align :code :loop) - write8-loop - (:movb (:ebx) :al) - (:outb :al :dx) - (:incl :ebx) - (:decl :ecx) - (:jnz 'write8-loop))) - (:16-bits - ;; each 16-bits IOW maps to two u2 - (with-inline-assembly (:returns :nothing) - (:compile-form (:result-mode :edx) port) - (:shrl #.movitz::+movitz-fixnum-shift+ :edx) - (:compile-form (:result-mode :ebx) sequence) - (:compile-form (:result-mode :ecx) start) - (:addl #.(bt:slot-offset 'movitz::movitz-vector 'movitz::data) :ebx) - (:shrl #.movitz::+movitz-fixnum-shift+ :ecx) - (:addl :ecx :ebx) - (:compile-form (:result-mode :ecx) size) - (:xorl :eax :eax) - (:shrl #.(cl:1+ movitz::+movitz-fixnum-shift+) :ecx) - (:align :code :loop) - write16-loop - (:movw (:ebx) :ax) - (:outw :ax :dx) - (:addl 2 :ebx) - (:decl :ecx) - (:jnz 'write16-loop)))))))) - (vector - (unless end (setf end (length sequence))) - (let ((size (- end start))) - (ecase type - (:character - (ecase (or transfer-unit :8-bits) - (:8-bits - (dotimes (i size) - (setf (io-port port :character) - (char sequence (+ start i))))))) - (:unsigned-byte8 - (ecase (or transfer-unit :8-bits) - (:8-bits - ;; one-to-one 8 bits - (dotimes (i size) - (setf (io-port port :unsigned-byte8) - (aref sequence (+ start i))))) - (:16-bits - ;; two by two (8-bit) array elements into each 16-bit io-port - (dotimes (i (truncate size 2)) - (setf (io-port port :unsigned-byte16) - (dpb (aref sequence (+ start (* 2 i) 1)) ; little endian.. - (byte 8 8) - (aref sequence (+ start (* 2 i))))))) - ))))))) From ffjeld at common-lisp.net Tue Feb 3 10:36:06 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 03 Feb 2004 05:36:06 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv14596 Modified Files: compiler.lisp Log Message: Removed everything concerning "forward-2op", which I don't even remember what was about. Date: Tue Feb 3 05:36:06 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.7 movitz/compiler.lisp:1.8 --- movitz/compiler.lisp:1.7 Mon Feb 2 09:53:38 2004 +++ movitz/compiler.lisp Tue Feb 3 05:36:06 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.7 2004/02/02 14:53:38 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.8 2004/02/03 10:36:06 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -444,7 +444,6 @@ funobj) (defun complete-funobj (funobj) - ;; (assert (= 1 (length (function-envs funobj)))) (let ((code-specs (loop for (numargs . function-env) in (function-envs funobj) collecting @@ -456,16 +455,13 @@ (multiple-value-bind (prelude-code have-normalized-ecx-p) (make-compiled-function-prelude stack-frame-size function-env use-stack-frame-p (need-normalized-ecx-p function-env) frame-map - :do-check-stack-p t - :forward-2op-position - (when (forward-2op function-env) - (movitz-funobj-intern-constant funobj - (forward-2op function-env)))) - (let ((function-code (install-arg-cmp (append prelude-code - resolved-code - (make-compiled-function-postlude funobj function-env - use-stack-frame-p)) - have-normalized-ecx-p))) + :do-check-stack-p t) + (let ((function-code + (install-arg-cmp (append prelude-code + resolved-code + (make-compiled-function-postlude funobj function-env + use-stack-frame-p)) + have-normalized-ecx-p))) (let ((optimized-function-code (optimize-code function-code :keep-labels (nconc (subseq (movitz-funobj-const-list funobj) @@ -577,10 +573,7 @@ (make-compiled-body body-form funobj env top-level-p arg-init-code include-programs) (multiple-value-bind (prelude-code have-normalized-ecx-p) (make-compiled-function-prelude stack-frame-size env use-stack-frame-p - need-normalized-ecx-p frame-map - :forward-2op-position - (when (forward-2op env) - (new-movitz-funobj-intern-constant funobj (forward-2op env)))) + need-normalized-ecx-p frame-map) (values (install-arg-cmp (append prelude-code resolved-code (make-compiled-function-postlude funobj env use-stack-frame-p)) @@ -880,9 +873,6 @@ (2 '((:pushl :edi) (:pushl :edi))) (t `((:subl ,(* 4 stack-frame-init) :esp))))) - -(defvar muerte.cl:*compile-file-pathname* nil) - (defun movitz-compile-file (path &key ((:image *image*) *image*) load-priority (delete-file-p nil)) @@ -1010,8 +1000,12 @@ (defun optimize-code-unfold-branches (unoptimized-code) "This particular optimization should be done before code layout: (:jcc 'label) (:jmp 'foo) label => (:jncc 'foo) label" - (flet ((branch-instruction-label (i &optional jmp (branch-types '(:je :jne :jb :jnb :jbe :jz :jl :jnz - :jle :ja :jae :jg :jge :jnc :jc :js :jns))) + (flet ((explain (always format &rest args) + (when (or always *explain-peephole-optimizations*) + (warn "Peephole: ~?~&----------------------------" format args))) + (branch-instruction-label (i &optional jmp (branch-types '(:je :jne :jb :jnb :jbe :jz + :jl :jnz :jle :ja :jae :jg + :jge :jnc :jc :js :jns))) "If i is a branch, return the label." (when jmp (push :jmp branch-types)) (let ((i (ignore-instruction-prefixes i))) @@ -1039,10 +1033,10 @@ (branch-instruction-label i2 t nil) (symbolp i3) (eq i3 (branch-instruction-label i1))) - ;; (warn "Got a sit: ~{~&~A~}" (subseq pc 0 3)) (setf p (list `(,(negate-branch (car i1)) ',(branch-instruction-label i2 t nil)) i3) - next-pc (nthcdr 3 pc))) + next-pc (nthcdr 3 pc)) + (explain nil "Got a sit: ~{~&~A~} => ~{~&~A~}" (subseq pc 0 3) p)) nconc p))) (defun optimize-code-dirties (unoptimized-code) @@ -1050,7 +1044,10 @@ with other optimizations that track register usage. So this is performed just once, initially." (labels - ((twop-p (c &optional op) + ((explain (always format &rest args) + (when (or always *explain-peephole-optimizations*) + (warn "Peephole: ~?~&----------------------------" format args))) + (twop-p (c &optional op) (let ((c (ignore-instruction-prefixes c))) (and (listp c) (= 3 (length c)) (or (not op) (eq op (first c))) @@ -1086,7 +1083,7 @@ (eq regy (twop-dst i3 :cmpl)))) (setq p (list `(:cmpl ,(twop-src i2) ,(twop-src i1))) next-pc (nthcdr 3 pc)) - #+ignore (explain nil "4: ~S for ~S" p (subseq pc 0 4)))) + (explain nil "4: ~S for ~S" p (subseq pc 0 4)))) nconc p))) (defun optimize-code-internal (unoptimized-code recursive-count &rest key-args @@ -1387,6 +1384,7 @@ branch-map (intersection branch-map (rcode-map rcode) :test #'equal))))) (when (or full-map branch-map nil) + #+ignore (explain nil "Inserting at ~A frame-map ~S branch-map ~S." label full-map branch-map)) (setq p (list label `(:frame-map ,full-map ,branch-map)) @@ -1731,6 +1729,7 @@ `(:movl ,(idst i) ,(idst i3))) next-pc (nthcdr 4 pc)) (explain nil "~S => ~S" (subseq pc 0 4) p)) + #+ignore ((let ((i6 (nth 6 pc))) (and (global-funcall-p i2 '(fast-car)) (global-funcall-p i6 '(fast-cdr)) @@ -3090,8 +3089,7 @@ (defun make-compiled-function-prelude (stack-frame-size env use-stack-frame-p need-normalized-ecx-p frame-map - &key forward-2op-position - do-check-stack-p) + &key do-check-stack-p) "The prelude is compiled after the function's body is." (when (without-function-prelude-p env) (return-from make-compiled-function-prelude @@ -3243,16 +3241,6 @@ (append (make-compiled-function-prelude-numarg-check min-args max-args) '(entry%3op) stack-frame-init-code)) - (forward-2op-position - (append `((:cmpb 2 :cl) - (:jne 'not-two-args) - entry%2op - (:movl (:esi ,forward-2op-position) :edx) - (:movl (:edx ,(slot-offset 'movitz-symbol 'function-value)) :esi) - (:jmp (:esi ,(slot-offset 'movitz-funobj 'code-vector%2op))) - not-two-args) - stack-frame-init-code - (make-compiled-function-prelude-numarg-check min-args max-args))) (t (append stack-frame-init-code (make-compiled-function-prelude-numarg-check min-args max-args)))) '(start-stack-frame-setup) From ffjeld at common-lisp.net Tue Feb 3 18:02:16 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 03 Feb 2004 13:02:16 -0500 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv12294 Modified Files: image.lisp Log Message: Ensure create-image returns *image* also on ACL. Date: Tue Feb 3 13:02:16 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.5 movitz/image.lisp:1.6 --- movitz/image.lisp:1.5 Mon Feb 2 08:27:26 2004 +++ movitz/image.lisp Tue Feb 3 13:02:15 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.5 2004/02/02 13:27:26 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.6 2004/02/03 18:02:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -688,9 +688,8 @@ (when init-file (movitz-compile-file init-file)) *image*) - *i* (when (boundp '*image*) *image*)) - ;; #+acl (excl:gc) - *image*)) + *i* (when (boundp '*image*) *image*))) + *image*) (defun dump-image (&key (path *default-image-file*) ((:image *image*) *image*) (multiboot-p t) ignore-dump-count) From ffjeld at common-lisp.net Tue Feb 3 18:02:59 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 03 Feb 2004 13:02:59 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv14532 Modified Files: compiler.lisp Log Message: Various rearrangements. No code produced by the compiler should change due to these changes. Date: Tue Feb 3 13:02:59 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.8 movitz/compiler.lisp:1.9 --- movitz/compiler.lisp:1.8 Tue Feb 3 05:36:06 2004 +++ movitz/compiler.lisp Tue Feb 3 13:02:59 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.8 2004/02/03 10:36:06 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.9 2004/02/03 18:02:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -207,22 +207,29 @@ (function-env (add-bindings-from-lambda-list lambda-list (make-local-movitz-environment funobj-env funobj - :type 'function-env - :declaration-context :funobj - :declarations declarations)))) + :type 'function-env + :declaration-context :funobj + :declarations declarations)))) (setf (movitz-funobj-name funobj) name (movitz-funobj-lambda-list funobj) (movitz-read (lambda-list-simplify lambda-list)) (funobj-env funobj) funobj-env (function-envs funobj) (list (cons 'muerte.cl::t function-env))) - (make-compiled-body-pass1 funobj function-env form top-level-p))) + (cond + #+ignore + ((and (= 1 (length (required-vars function-env))) + (= 1 (length (optional-vars function-env))) + (null (key-vars function-env)) + (null (rest-var function-env))) + (make-compiled-body-pass1-1req1opt funobj function-env form top-level-p)) + (t (make-compiled-body-pass1 funobj function-env form top-level-p))))) (defun make-compiled-body-pass1 (funobj function-env form top-level-p) "Returns compiler-values, with the pass1 funobj as &final-form." - (multiple-value-bind (arg-init-code body-form need-normalized-ecx-p) - (make-function-arguments-init funobj function-env form) + (multiple-value-bind (arg-init-code need-normalized-ecx-p) + (make-function-arguments-init funobj function-env) (compiler-values-bind (&code body-code) (compiler-call #'compile-form - :form body-form + :form (make-special-funarg-shadowing function-env form) :funobj funobj :env function-env :top-level-p top-level-p @@ -475,6 +482,7 @@ (code3 (cdr (assoc 3 code-specs))) (codet (cdr (assoc 'muerte.cl::t code-specs)))) (assert codet () "A default numargs-case is required.") + ;; (format t "codet:~{~&~A~}" codet) (let ((combined-code (delete 'start-stack-frame-setup (append @@ -499,67 +507,74 @@ '(entry%3op (:movb 3 :cl))) , at code3 not-three-args)) - codet)))) + (delete-if (lambda (x) + (or (and code1 (eq x 'entry%1op)) + (and code2 (eq x 'entry%2op)) + (and code3 (eq x 'entry%3op)))) + codet))))) ;; (warn "opt code: ~{~&~A~}" optimized-function-code) - (multiple-value-bind (code-vector code-symtab) - (ia-x86:proglist-encode :octet-vector :32-bit #x00000000 - (ia-x86:read-proglist (append combined-code - `((% bytes 8 0 0 0)))) - :symtab-lookup - (lambda (label) - (case label - (:nil-value (image-nil-word *image*)) - (t (let ((set (cdr (assoc label - (movitz-funobj-jumpers-map funobj))))) - (when set - (let ((pos (search set (movitz-funobj-const-list funobj) - :end2 (movitz-funobj-num-jumpers funobj)))) - (assert pos () - "Couldn't find for ~s set ~S in ~S." - label set (subseq (movitz-funobj-const-list funobj) - 0 (movitz-funobj-num-jumpers funobj))) - (* 4 pos)))))))) - (setf (movitz-funobj-symtab funobj) code-symtab) - (let ((code-length (- (length code-vector) 3))) - (assert (not (mismatch #(0 0 0) code-vector :start2 code-length)) () - "No space in code-vector was allocated for entry-points.") - (setf (fill-pointer code-vector) code-length) - ;; debug info - (setf (ldb (byte 1 5) (slot-value funobj 'debug-info)) - 1 #+ignore (if use-stack-frame-p 1 0)) - (let ((x (cdr (assoc 'start-stack-frame-setup code-symtab)))) - (cond - ((not x) - #+ignore (warn "No start-stack-frame-setup label for ~S." name)) - ((<= 0 x 30) - (setf (ldb (byte 5 0) (slot-value funobj 'debug-info)) x)) - (t (warn "Can't encode start-stack-frame-setup label ~D into debug-info for ~S." - x (movitz-funobj-name funobj))))) - (loop for ((entry-label slot-name) . rest) on '((entry%1op code-vector%1op) - (entry%2op code-vector%2op) - (entry%3op code-vector%3op)) - do (cond - ((assoc entry-label code-symtab) - (let ((offset (cdr (assoc entry-label code-symtab)))) - (setf (slot-value funobj slot-name) - (cons offset funobj)) - (vector-push offset code-vector))) - ((some (lambda (label) (assoc label code-symtab)) - (mapcar #'car rest)) - (vector-push 0 code-vector)))) - (setf (movitz-funobj-code-vector funobj) - (make-movitz-vector (length code-vector) - :fill-pointer code-length - :element-type 'movitz-code - :initial-contents code-vector - :flags '(:code-vector-p) - :alignment 16 - :alignment-offset 8))))))) + (assemble-funobj funobj combined-code)))) (loop for (sub-function-binding) on (sub-function-binding-usage funobj) by #'cddr do (complete-funobj (function-binding-funobj sub-function-binding))) funobj) +(defun assemble-funobj (funobj combined-code) + (multiple-value-bind (code-vector code-symtab) + (ia-x86:proglist-encode :octet-vector :32-bit #x00000000 + (ia-x86:read-proglist (append combined-code + `((% bytes 8 0 0 0)))) + :symtab-lookup + (lambda (label) + (case label + (:nil-value (image-nil-word *image*)) + (t (let ((set (cdr (assoc label + (movitz-funobj-jumpers-map funobj))))) + (when set + (let ((pos (search set (movitz-funobj-const-list funobj) + :end2 (movitz-funobj-num-jumpers funobj)))) + (assert pos () + "Couldn't find for ~s set ~S in ~S." + label set (subseq (movitz-funobj-const-list funobj) + 0 (movitz-funobj-num-jumpers funobj))) + (* 4 pos)))))))) + (setf (movitz-funobj-symtab funobj) code-symtab) + (let ((code-length (- (length code-vector) 3))) + (assert (not (mismatch #(0 0 0) code-vector :start2 code-length)) () + "No space in code-vector was allocated for entry-points.") + (setf (fill-pointer code-vector) code-length) + ;; debug info + (setf (ldb (byte 1 5) (slot-value funobj 'debug-info)) + 1 #+ignore (if use-stack-frame-p 1 0)) + (let ((x (cdr (assoc 'start-stack-frame-setup code-symtab)))) + (cond + ((not x) + #+ignore (warn "No start-stack-frame-setup label for ~S." name)) + ((<= 0 x 30) + (setf (ldb (byte 5 0) (slot-value funobj 'debug-info)) x)) + (t (warn "Can't encode start-stack-frame-setup label ~D into debug-info for ~S." + x (movitz-funobj-name funobj))))) + (loop for ((entry-label slot-name) . rest) on '((entry%1op code-vector%1op) + (entry%2op code-vector%2op) + (entry%3op code-vector%3op)) + do (cond + ((assoc entry-label code-symtab) + (let ((offset (cdr (assoc entry-label code-symtab)))) + (setf (slot-value funobj slot-name) + (cons offset funobj)) + (vector-push offset code-vector))) + ((some (lambda (label) (assoc label code-symtab)) + (mapcar #'car rest)) + (vector-push 0 code-vector)))) + (setf (movitz-funobj-code-vector funobj) + (make-movitz-vector (length code-vector) + :fill-pointer code-length + :element-type 'movitz-code + :initial-contents code-vector + :flags '(:code-vector-p) + :alignment 16 + :alignment-offset 8))))) + #+ignore (defun make-compiled-function-body-default (form funobj env top-level-p) (make-compiled-body-pass2 (make-compiled-function-pass1 form funobj env top-level-p) @@ -915,6 +930,7 @@ :declaration-context :funobj)) (file-code (with-compilation-unit () + (add-bindings-from-lambda-list () function-env) (with-open-file (stream path :direction :input) (setf (funobj-env funobj) funobj-env) (loop for form = (with-movitz-syntax () @@ -3358,12 +3374,12 @@ `(:cmpb ,arg-count :cl)) (t `(:cmpl ,(dpb arg-count (byte 24 8) #x80) :ecx))))))) -(defun make-function-arguments-init (funobj env function-body) +(defun make-function-arguments-init (funobj env) "The arugments-init is compiled before the function's body is. -Return arg-init-code, new function-body, need-normalized-ecx-p." +Return arg-init-code, need-normalized-ecx-p." (when (without-function-prelude-p env) (return-from make-function-arguments-init - (values nil function-body nil))) + (values nil nil))) (let ((need-normalized-ecx-p nil) (required-vars (required-vars env)) (optional-vars (optional-vars env)) @@ -3455,47 +3471,47 @@ ,not-present-label)) (t #+ignore (when (= 0 (function-argument-argnum binding)) (setf eax-optional-destructive-p t)) - `((:arg-cmp ,(function-argument-argnum binding)) - (:jbe ',not-present-label) - ,@(when supplied-p-var - `((:movl (:edi ,(global-constant-offset 't-symbol)) :eax) - (:store-lexical ,supplied-p-binding :eax - :type (eql ,(image-t-symbol *image*))))) - ,@(case (function-argument-argnum binding) - (0 `((:store-lexical ,binding :eax :type t))) - (1 `((:store-lexical ,binding :ebx :type t))) - (t (cond - (last-optional-p - `((:movl (:ebp ,(* 4 (- (1+ (function-argument-argnum binding)) - -1 (function-argument-argnum binding)))) - :eax) - (:store-lexical ,binding :eax :type t))) - (t (setq need-normalized-ecx-p t) - `((:movl (:ebp (:ecx 4) ,(* -4 (1- (function-argument-argnum binding)))) - :eax) - (:store-lexical ,binding :eax :type t)))))) - (:jmp ',optional-ok-label) - ,not-present-label - ,@(when supplied-p-var - `((:store-lexical ,supplied-p-binding :edi :type null))) - ,@(when (and (= 0 (function-argument-argnum binding)) - (not last-optional-p)) - `((:pushl :ebx))) ; protect ebx - ,@(if (optional-function-argument-init-form binding) - (append '((:pushl :ecx)) - (when (= 0 (function-argument-argnum binding)) - `((:pushl :ebx))) - init-code-edx - `((:store-lexical ,binding :edx :type t)) - (when (= 0 (function-argument-argnum binding)) - `((:popl :ebx))) - `((:popl :ecx))) - (progn (error "WEgewgew") - `((:store-lexical ,binding :edi :type null)))) - ,@(when (and (= 0 (function-argument-argnum binding)) - (not last-optional-p)) - `((:popl :ebx))) ; protect ebx - ,optional-ok-label))))) + `((:arg-cmp ,(function-argument-argnum binding)) + (:jbe ',not-present-label) + ,@(when supplied-p-var + `((:movl (:edi ,(global-constant-offset 't-symbol)) :eax) + (:store-lexical ,supplied-p-binding :eax + :type (eql ,(image-t-symbol *image*))))) + ,@(case (function-argument-argnum binding) + (0 `((:store-lexical ,binding :eax :type t))) + (1 `((:store-lexical ,binding :ebx :type t))) + (t (cond + (last-optional-p + `((:movl (:ebp ,(* 4 (- (1+ (function-argument-argnum binding)) + -1 (function-argument-argnum binding)))) + :eax) + (:store-lexical ,binding :eax :type t))) + (t (setq need-normalized-ecx-p t) + `((:movl (:ebp (:ecx 4) ,(* -4 (1- (function-argument-argnum binding)))) + :eax) + (:store-lexical ,binding :eax :type t)))))) + (:jmp ',optional-ok-label) + ,not-present-label + ,@(when supplied-p-var + `((:store-lexical ,supplied-p-binding :edi :type null))) + ,@(when (and (= 0 (function-argument-argnum binding)) + (not last-optional-p)) + `((:pushl :ebx))) ; protect ebx + ,@(if (optional-function-argument-init-form binding) + (append '((:pushl :ecx)) + (when (= 0 (function-argument-argnum binding)) + `((:pushl :ebx))) + init-code-edx + `((:store-lexical ,binding :edx :type t)) + (when (= 0 (function-argument-argnum binding)) + `((:popl :ebx))) + `((:popl :ecx))) + (progn (error "WEgewgew") + `((:store-lexical ,binding :edi :type null)))) + ,@(when (and (= 0 (function-argument-argnum binding)) + (not last-optional-p)) + `((:popl :ebx))) ; protect ebx + ,optional-ok-label))))) (when rest-var (let* ((rest-binding (movitz-binding rest-var env)) (rest-position (function-argument-argnum rest-binding))) @@ -3649,11 +3665,16 @@ `((:init-lexvar ,binding :init-with-register :eax :init-with-type t))))))) - ;; shadowing variables.. - (if (special-variable-shadows env) - `(muerte.cl::let ,(special-variable-shadows env) ,function-body) - function-body) need-normalized-ecx-p))) + +(defun make-special-funarg-shadowing (env function-body) + "" + (cond + ((without-function-prelude-p env) + function-body) + ((special-variable-shadows env) + `(muerte.cl::let ,(special-variable-shadows env) ,function-body)) + (t function-body))) (defun make-compiled-function-postlude (funobj env use-stack-frame-p) (declare (ignore funobj env)) From ffjeld at common-lisp.net Tue Feb 3 19:17:25 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 03 Feb 2004 14:17:25 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30385 Modified Files: compiler.lisp Log Message: Changed some function signatures in the compiler. Date: Tue Feb 3 14:17:24 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.9 movitz/compiler.lisp:1.10 --- movitz/compiler.lisp:1.9 Tue Feb 3 13:02:59 2004 +++ movitz/compiler.lisp Tue Feb 3 14:17:24 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.9 2004/02/03 18:02:59 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.10 2004/02/03 19:17:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -139,22 +139,21 @@ lambda-form) (coerce lambda-form 'function))) -(defun make-compiled-funobj (&rest args) +(defun make-compiled-funobj (name lambda-list declarations form env top-level-p funobj) (handler-bind (((or warning error) (lambda (c) (declare (ignore c)) (if (not (boundp 'muerte.cl:*compile-file-pathname*)) (format *error-output* - "~&;; While Movitz compiling ~S:" - (car args)) + "~&;; While Movitz compiling ~S:" name) (format *error-output* "~&;; While Movitz compiling ~S in ~A:" - (car args) muerte.cl:*compile-file-pathname*))))) + name muerte.cl:*compile-file-pathname*))))) (register-function-code-size - (make-compiled-funobj-pass2 (apply #'make-compiled-funobj-pass1 args))))) + (make-compiled-funobj-pass2 + (make-compiled-funobj-pass1 name lambda-list declarations form env top-level-p funobj))))) -(defun make-compiled-funobj-pass1 (name lambda-list declarations form env top-level-p - &key funobj) +(defun make-compiled-funobj-pass1 (name lambda-list declarations form env top-level-p funobj) "Entry-point for first-pass compilation." (with-retries-until-true (retry-pass1 "Retry first-pass compilation of ~S." name) ;; First-pass is mostly functional, so it can safely be restarted. @@ -164,10 +163,9 @@ (eq 'muerte::numargs-case (caar sub-form)))) 'make-compiled-function-pass1-numarg-case) (t 'make-compiled-function-pass1)) - name lambda-list declarations form env top-level-p :funobj funobj))) + name lambda-list declarations form env top-level-p funobj))) -(defun make-compiled-function-pass1-numarg-case (name lambda-list declarations form env top-level-p - &key funobj) +(defun make-compiled-function-pass1-numarg-case (name lambda-list declarations form env top-level-p funobj) (let* ((funobj (or funobj (make-instance 'movitz-funobj-pass1))) (funobj-env (make-local-movitz-environment env funobj :type 'funobj-env))) (setf (movitz-funobj-name funobj) name @@ -197,8 +195,7 @@ (function-envs funobj))))) funobj)) -(defun make-compiled-function-pass1 (name lambda-list declarations form env top-level-p - &key funobj) +(defun make-compiled-function-pass1 (name lambda-list declarations form env top-level-p funobj) "Returns compiler-values, with the pass1 funobj as &final-form." (when (duplicatesp lambda-list) (error "There are duplicates in lambda-list ~S." lambda-list)) From ffjeld at common-lisp.net Tue Feb 3 19:17:30 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 03 Feb 2004 14:17:30 -0500 Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30418 Modified Files: special-operators-cl.lisp Log Message: Changed some function signatures in the compiler. Date: Tue Feb 3 14:17:30 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.4 movitz/special-operators-cl.lisp:1.5 --- movitz/special-operators-cl.lisp:1.4 Mon Feb 2 09:52:24 2004 +++ movitz/special-operators-cl.lisp Tue Feb 3 14:17:30 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.4 2004/02/02 14:52:24 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.5 2004/02/03 19:17:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -887,7 +887,7 @@ (cadr name) lambda-declarations `(muerte.cl:progn , at lambda-forms) - env nil))) + env nil nil))) (let ((lambda-binding (make-instance 'lambda-binding :name (gensym "anonymous-lambda-") :parent-funobj funobj @@ -950,7 +950,7 @@ (list* 'muerte.cl:block (compute-function-block-name flet-name) flet-body) - env nil))) + env nil nil))) do (movitz-env-add-binding flet-env flet-binding) collect `(:local-function-init ,flet-binding)))) (compiler-values-bind (&all body-values &code body-code) @@ -1057,7 +1057,7 @@ (compute-function-block-name labels-name) labels-body) labels-env nil - :funobj (function-binding-funobj labels-binding))) + (function-binding-funobj labels-binding))) collect `(:local-function-init ,labels-binding)))) (compiler-values-bind (&all body-values &code body-code) (compiler-call #'compile-implicit-progn From ffjeld at common-lisp.net Tue Feb 3 19:17:34 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 03 Feb 2004 14:17:34 -0500 Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv31106 Modified Files: special-operators.lisp Log Message: Changed some function signatures in the compiler. Date: Tue Feb 3 14:17:34 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.4 movitz/special-operators.lisp:1.5 --- movitz/special-operators.lisp:1.4 Mon Feb 2 09:54:29 2004 +++ movitz/special-operators.lisp Tue Feb 3 14:17:34 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.4 2004/02/02 14:54:29 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.5 2004/02/03 19:17:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -259,7 +259,7 @@ (declare (ignore c)) (format *error-output* "~&;; In function ~S:~&" name)))) (let* ((*compiling-function-name* name) - (funobj (make-compiled-funobj name formals declarations body env nil))) + (funobj (make-compiled-funobj name formals declarations body env nil nil))) (setf (movitz-funobj-symbolic-name funobj) name) (setf (movitz-env-named-function name) funobj)))) (compiler-values ())) From ffjeld at common-lisp.net Tue Feb 3 19:18:43 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 03 Feb 2004 14:18:43 -0500 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv3200 Modified Files: image.lisp Log Message: Fixed call to make-compiled-funobj. Date: Tue Feb 3 14:18:43 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.6 movitz/image.lisp:1.7 --- movitz/image.lisp:1.6 Tue Feb 3 13:02:15 2004 +++ movitz/image.lisp Tue Feb 3 14:18:43 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.6 2004/02/03 18:02:15 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.7 2004/02/03 19:18:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1469,7 +1469,7 @@ , at toplevel-code (muerte::halt-cpu)) - nil t))) + nil t nil))) (defun mkasm-write-word-eax-ebx () (let ((loop-label (make-symbol "write-word-loop")) From ffjeld at common-lisp.net Wed Feb 4 10:33:14 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 04 Feb 2004 05:33:14 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv26141 Modified Files: compiler.lisp Log Message: Rearranging compiler code somewhat. Still no change in compiler functionality. Date: Wed Feb 4 05:33:14 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.10 movitz/compiler.lisp:1.11 --- movitz/compiler.lisp:1.10 Tue Feb 3 14:17:24 2004 +++ movitz/compiler.lisp Wed Feb 4 05:33:14 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.10 2004/02/03 19:17:24 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.11 2004/02/04 10:33:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -108,7 +108,7 @@ (defconstant +code-vector-entry-factor+ 1) -(defclass movitz-funobj-pass1 (movitz-heap-object) +(defclass movitz-funobj-pass1 () ((name :initarg :name :accessor movitz-funobj-name) @@ -119,13 +119,14 @@ :accessor function-envs) (funobj-env :initarg :funobj-env - :accessor funobj-env) - (body-compiler-values - :accessor body-compiler-values)) + :accessor funobj-env)) (:documentation "This class is used for funobjs during the first compiler pass. Before the second pass, such objects will be change-class-ed to proper movitz-funobjs. This way, we ensure that no undue side-effects on the funobj occur during pass 1.")) +(defclass movitz-funobj-pass1-numargs-case (movitz-funobj-pass1) ()) +(defclass movitz-funobj-pass1-1req1opt (movitz-funobj-pass1) ()) + (defmethod print-object ((object movitz-funobj-pass1) stream) (print-unreadable-object (object stream :type t :identity t) (when (slot-boundp object 'name) @@ -140,6 +141,7 @@ (coerce lambda-form 'function))) (defun make-compiled-funobj (name lambda-list declarations form env top-level-p funobj) + "Compiler entry-point for making a (lexically) top-level function." (handler-bind (((or warning error) (lambda (c) (declare (ignore c)) @@ -151,22 +153,32 @@ name muerte.cl:*compile-file-pathname*))))) (register-function-code-size (make-compiled-funobj-pass2 - (make-compiled-funobj-pass1 name lambda-list declarations form env top-level-p funobj))))) + (make-compiled-funobj-pass1 name lambda-list declarations + form env top-level-p funobj))))) (defun make-compiled-funobj-pass1 (name lambda-list declarations form env top-level-p funobj) "Entry-point for first-pass compilation." (with-retries-until-true (retry-pass1 "Retry first-pass compilation of ~S." name) ;; First-pass is mostly functional, so it can safely be restarted. - (funcall (cond - ((let ((sub-form (cddr form))) - (and (consp (car sub-form)) - (eq 'muerte::numargs-case (caar sub-form)))) - 'make-compiled-function-pass1-numarg-case) - (t 'make-compiled-function-pass1)) - name lambda-list declarations form env top-level-p funobj))) + (multiple-value-bind (required-vars optional-vars rest-var key-vars) + (decode-normal-lambda-list lambda-list) + ;; There are several main branches through the function + ;; compiler, and this is where we decide which to take. + (funcall (cond + ((let ((sub-form (cddr form))) + (and (consp (car sub-form)) + (eq 'muerte::numargs-case (caar sub-form)))) + 'make-compiled-function-pass1-numarg-case) + ((and (= 1 (length required-vars)) + (= 1 (length optional-vars)) + (null key-vars) + (not rest-var)) + 'make-compiled-function-pass1) + (t 'make-compiled-function-pass1)) + name lambda-list declarations form env top-level-p funobj)))) (defun make-compiled-function-pass1-numarg-case (name lambda-list declarations form env top-level-p funobj) - (let* ((funobj (or funobj (make-instance 'movitz-funobj-pass1))) + (let* ((funobj (or funobj (make-instance 'movitz-funobj-pass1-numargs-case))) (funobj-env (make-local-movitz-environment env funobj :type 'funobj-env))) (setf (movitz-funobj-name funobj) name (movitz-funobj-lambda-list funobj) (movitz-read (lambda-list-simplify lambda-list)) @@ -244,6 +256,7 @@ (resolve-sub-functions funobj))))) (defun analyze-bindings (toplevel-funobj) + "Figure out usage of bindings in a toplevel funobj." (let ((bindings ())) (labels ((type-is-t (type-specifier) (or (eq type-specifier t) From ffjeld at common-lisp.net Wed Feb 4 15:25:16 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 04 Feb 2004 10:25:16 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv14912 Modified Files: compiler.lisp Log Message: More smallish rearrangement of compiler code, and some comments. Date: Wed Feb 4 10:25:16 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.11 movitz/compiler.lisp:1.12 --- movitz/compiler.lisp:1.11 Wed Feb 4 05:33:14 2004 +++ movitz/compiler.lisp Wed Feb 4 10:25:15 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.11 2004/02/04 10:33:14 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.12 2004/02/04 15:25:15 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -154,10 +154,15 @@ (register-function-code-size (make-compiled-funobj-pass2 (make-compiled-funobj-pass1 name lambda-list declarations - form env top-level-p funobj))))) + form env top-level-p :funobj funobj))))) -(defun make-compiled-funobj-pass1 (name lambda-list declarations form env top-level-p funobj) - "Entry-point for first-pass compilation." +(defun make-compiled-funobj-pass1 (name lambda-list declarations form env top-level-p + &key funobj) + "Per funobj (i.e. not necessarily top-level) entry-point for first-pass compilation. +If funobj is provided, its identity will be kept, but its type (and values) might change." + ;; The ability to provide funobj's identity is important when a + ;; function must be referenced before it can be compiled, e.g. for + ;; mutually recursive (lexically bound) functions. (with-retries-until-true (retry-pass1 "Retry first-pass compilation of ~S." name) ;; First-pass is mostly functional, so it can safely be restarted. (multiple-value-bind (required-vars optional-vars rest-var key-vars) @@ -189,15 +194,16 @@ (error "There are duplicates in lambda-list ~S." lambda-list)) (multiple-value-bind (clause-body clause-declarations) (parse-declarations-and-body clause-body) - (let ((function-env (add-bindings-from-lambda-list - lambda-list - (make-local-movitz-environment funobj-env funobj - :type 'function-env - :declaration-context :funobj - :declarations - (append clause-declarations - declarations))))) - (make-compiled-body-pass1 funobj + (let ((function-env + (add-bindings-from-lambda-list lambda-list + (make-local-movitz-environment + funobj-env funobj + :type 'function-env + :declaration-context :funobj + :declarations + (append clause-declarations + declarations))))) + (make-compiled-function-body-pass1 funobj function-env (list* 'muerte.cl::block (compute-function-block-name name) @@ -208,7 +214,7 @@ funobj)) (defun make-compiled-function-pass1 (name lambda-list declarations form env top-level-p funobj) - "Returns compiler-values, with the pass1 funobj as &final-form." + "Returns funobj." (when (duplicatesp lambda-list) (error "There are duplicates in lambda-list ~S." lambda-list)) (let* ((funobj (or funobj (make-instance 'movitz-funobj-pass1))) @@ -223,37 +229,33 @@ (movitz-funobj-lambda-list funobj) (movitz-read (lambda-list-simplify lambda-list)) (funobj-env funobj) funobj-env (function-envs funobj) (list (cons 'muerte.cl::t function-env))) - (cond - #+ignore - ((and (= 1 (length (required-vars function-env))) - (= 1 (length (optional-vars function-env))) - (null (key-vars function-env)) - (null (rest-var function-env))) - (make-compiled-body-pass1-1req1opt funobj function-env form top-level-p)) - (t (make-compiled-body-pass1 funobj function-env form top-level-p))))) - -(defun make-compiled-body-pass1 (funobj function-env form top-level-p) - "Returns compiler-values, with the pass1 funobj as &final-form." - (multiple-value-bind (arg-init-code need-normalized-ecx-p) - (make-function-arguments-init funobj function-env) - (compiler-values-bind (&code body-code) - (compiler-call #'compile-form - :form (make-special-funarg-shadowing function-env form) - :funobj funobj - :env function-env - :top-level-p top-level-p - :result-mode :function) - (let ((extended-code (append arg-init-code body-code))) - (setf (extended-code function-env) extended-code - (need-normalized-ecx-p function-env) need-normalized-ecx-p) - funobj)))) - -(defun make-compiled-funobj-pass2 (funobj) - (check-type funobj movitz-funobj-pass1) - (complete-funobj - (layout-stack-frames - (analyze-bindings - (resolve-sub-functions funobj))))) + (make-compiled-function-body-pass1 funobj function-env form top-level-p))) + +(defun make-compiled-function-body-pass1 (funobj function-env form top-level-p) + "Returns the funobj with its extended-code." + (compiler-values-bind (&code body-code) + (compiler-call #'compile-form + :form (make-special-funarg-shadowing function-env form) + :funobj funobj + :env function-env + :top-level-p top-level-p + :result-mode :function) + (multiple-value-bind (arg-init-code need-normalized-ecx-p) + (make-function-arguments-init funobj function-env) + (setf (extended-code function-env) (append arg-init-code body-code) + (need-normalized-ecx-p function-env) need-normalized-ecx-p) + funobj))) + +(defun make-compiled-funobj-pass2 (toplevel-funobj-pass1) + "This is where second pass compilation for each top-level funobj begins." + (check-type toplevel-funobj-pass1 movitz-funobj-pass1) + (let ((toplevel-funobj (change-class toplevel-funobj-pass1 'movitz-funobj))) + (multiple-value-bind (toplevel-funobj function-binding-usage) + (resolve-borrowed-bindings toplevel-funobj) + (complete-funobj + (layout-stack-frames + (analyze-bindings + (resolve-sub-functions toplevel-funobj function-binding-usage))))))) (defun analyze-bindings (toplevel-funobj) "Figure out usage of bindings in a toplevel funobj." @@ -299,9 +301,8 @@ a borrowing-binding in the funobj-env. This process must be done recursively, depth-first wrt. sub-functions. Also, return a plist of all function-bindings seen." - (let ((toplevel-funobj (change-class toplevel-funobj 'movitz-funobj - :borrowed-bindings nil)) - (function-binding-usage ())) + (check-type toplevel-funobj movitz-funobj) + (let ((function-binding-usage ())) (labels ((process-binding (funobj binding usages) (typecase binding (forwarding-binding @@ -383,41 +384,41 @@ (values (resolve-funobj-borrowing toplevel-funobj) function-binding-usage)))) -(defun resolve-sub-functions (toplevel-funobj) - (multiple-value-bind (toplevel-funobj function-binding-usage) - (resolve-borrowed-bindings toplevel-funobj) - (assert (null (borrowed-bindings toplevel-funobj)) () - "Can't deal with toplevel closures yet.") - (setf (movitz-funobj-extent toplevel-funobj) :indefinite-extent) - (let ((sub-funobj-index 0)) - (loop for (function-binding usage) on function-binding-usage by #'cddr - 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 - (setf (movitz-funobj-name sub-funobj) - (list :anonymous-lambda - (movitz-funobj-name toplevel-funobj) - (post-incf sub-funobj-index))))) - (cond - ((or (null usage) - (null (borrowed-bindings sub-funobj))) - (change-class function-binding 'funobj-binding) - (setf (movitz-funobj-extent sub-funobj) - :indefinite-extent)) - ((equal usage '(:call)) - (change-class function-binding 'closure-binding) +(defun resolve-sub-functions (toplevel-funobj function-binding-usage) +;;; (multiple-value-bind (toplevel-funobj function-binding-usage) +;;; (resolve-borrowed-bindings toplevel-funobj) + (assert (null (borrowed-bindings toplevel-funobj)) () + "Can't deal with toplevel closures yet.") + (setf (movitz-funobj-extent toplevel-funobj) :indefinite-extent) + (let ((sub-funobj-index 0)) + (loop for (function-binding usage) on function-binding-usage by #'cddr + 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 + (setf (movitz-funobj-name sub-funobj) + (list :anonymous-lambda + (movitz-funobj-name toplevel-funobj) + (post-incf sub-funobj-index))))) + (cond + ((or (null usage) + (null (borrowed-bindings sub-funobj))) + (change-class function-binding 'funobj-binding) + (setf (movitz-funobj-extent sub-funobj) + :indefinite-extent)) + ((equal usage '(:call)) + (change-class function-binding 'closure-binding) + (setf (movitz-funobj-extent sub-funobj) + :lexical-extent)) + (t (change-class function-binding 'closure-binding) (setf (movitz-funobj-extent sub-funobj) - :lexical-extent)) - (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))))) - (loop for function-binding in function-binding-usage by #'cddr - do (finalize-funobj (function-binding-funobj function-binding))) - (finalize-funobj toplevel-funobj))) + :indefinite-extent))) ; XXX + #+ignore (warn "extent: ~S => ~S" + 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)) (defun finalize-funobj (funobj) "Calculate funobj's constants, jumpers." From ffjeld at common-lisp.net Wed Feb 4 15:25:23 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 04 Feb 2004 10:25:23 -0500 Subject: [movitz-cvs] CVS update: movitz/special-operators-cl.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv28514 Modified Files: special-operators-cl.lisp Log Message: More smallish rearrangement of compiler code, and some comments. Date: Wed Feb 4 10:25:23 2004 Author: ffjeld Index: movitz/special-operators-cl.lisp diff -u movitz/special-operators-cl.lisp:1.5 movitz/special-operators-cl.lisp:1.6 --- movitz/special-operators-cl.lisp:1.5 Tue Feb 3 14:17:30 2004 +++ movitz/special-operators-cl.lisp Wed Feb 4 10:25:23 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.5 2004/02/03 19:17:30 ffjeld Exp $ +;;;; $Id: special-operators-cl.lisp,v 1.6 2004/02/04 15:25:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -887,7 +887,7 @@ (cadr name) lambda-declarations `(muerte.cl:progn , at lambda-forms) - env nil nil))) + env nil))) (let ((lambda-binding (make-instance 'lambda-binding :name (gensym "anonymous-lambda-") :parent-funobj funobj @@ -950,7 +950,7 @@ (list* 'muerte.cl:block (compute-function-block-name flet-name) flet-body) - env nil nil))) + env nil))) do (movitz-env-add-binding flet-env flet-binding) collect `(:local-function-init ,flet-binding)))) (compiler-values-bind (&all body-values &code body-code) @@ -1057,7 +1057,7 @@ (compute-function-block-name labels-name) labels-body) labels-env nil - (function-binding-funobj labels-binding))) + :funobj (function-binding-funobj labels-binding))) collect `(:local-function-init ,labels-binding)))) (compiler-values-bind (&all body-values &code body-code) (compiler-call #'compile-implicit-progn From ffjeld at common-lisp.net Wed Feb 4 15:25:28 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 04 Feb 2004 10:25:28 -0500 Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv7456 Modified Files: storage-types.lisp Log Message: More smallish rearrangement of compiler code, and some comments. Date: Wed Feb 4 10:25:28 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.3 movitz/storage-types.lisp:1.4 --- movitz/storage-types.lisp:1.3 Mon Feb 2 08:09:26 2004 +++ movitz/storage-types.lisp Wed Feb 4 10:25:28 2004 @@ -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.3 2004/02/02 13:09:26 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.4 2004/02/04 15:25:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -820,6 +820,7 @@ :accessor movitz-funobj-symtab) (borrowed-bindings :initarg :borrowed-bindings + :initform nil :accessor borrowed-bindings) (function-envs :accessor function-envs) From ffjeld at common-lisp.net Wed Feb 4 15:25:33 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 04 Feb 2004 10:25:33 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv15293 Modified Files: los-closette-compiler.lisp Log Message: More smallish rearrangement of compiler code, and some comments. Date: Wed Feb 4 10:25:33 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.2 movitz/losp/muerte/los-closette-compiler.lisp:1.3 --- movitz/losp/muerte/los-closette-compiler.lisp:1.2 Mon Jan 19 06:23:46 2004 +++ movitz/losp/muerte/los-closette-compiler.lisp Wed Feb 4 10:25:33 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.2 2004/01/19 11:23:46 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.3 2004/02/04 15:25:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1578,10 +1578,10 @@ (multiple-value-bind (body declarations) (movitz::parse-docstring-declarations-and-body decl-doc-body 'cl:declare) (movitz::make-compiled-funobj name - (translate-program lambda-list :cl :muerte.cl) - (translate-program declarations :cl :muerte.cl) - (translate-program (cons 'muerte.cl:progn body) :cl :muerte.cl) - nil nil)))) + (translate-program lambda-list :cl :muerte.cl) + (translate-program declarations :cl :muerte.cl) + (translate-program (cons 'muerte.cl:progn body) :cl :muerte.cl) + nil nil nil)))) ;;; ;;; Bootstrap From ffjeld at common-lisp.net Wed Feb 4 15:29:25 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 04 Feb 2004 10:29:25 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13377 Modified Files: los-closette-compiler.lisp Log Message: Undo of last check-in to this file, really. Date: Wed Feb 4 10:29:25 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.3 movitz/losp/muerte/los-closette-compiler.lisp:1.4 --- movitz/losp/muerte/los-closette-compiler.lisp:1.3 Wed Feb 4 10:25:33 2004 +++ movitz/losp/muerte/los-closette-compiler.lisp Wed Feb 4 10:29:25 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.3 2004/02/04 15:25:33 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.4 2004/02/04 15:29:25 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1581,7 +1581,7 @@ (translate-program lambda-list :cl :muerte.cl) (translate-program declarations :cl :muerte.cl) (translate-program (cons 'muerte.cl:progn body) :cl :muerte.cl) - nil nil nil)))) + nil nil)))) ;;; ;;; Bootstrap From ffjeld at common-lisp.net Wed Feb 4 16:01:16 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 04 Feb 2004 11:01:16 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4480 Modified Files: compiler.lisp Log Message: Sync small edits. Date: Wed Feb 4 11:01:16 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.12 movitz/compiler.lisp:1.13 --- movitz/compiler.lisp:1.12 Wed Feb 4 10:25:15 2004 +++ movitz/compiler.lisp Wed Feb 4 11:01:14 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.12 2004/02/04 15:25:15 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.13 2004/02/04 16:01:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -140,7 +140,7 @@ lambda-form) (coerce lambda-form 'function))) -(defun make-compiled-funobj (name lambda-list declarations form env top-level-p funobj) +(defun make-compiled-funobj (name lambda-list declarations form env top-level-p &key funobj) "Compiler entry-point for making a (lexically) top-level function." (handler-bind (((or warning error) (lambda (c) From ffjeld at common-lisp.net Wed Feb 4 16:01:22 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 04 Feb 2004 11:01:22 -0500 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv21537 Modified Files: image.lisp Log Message: Sync small edits. Date: Wed Feb 4 11:01:21 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.7 movitz/image.lisp:1.8 --- movitz/image.lisp:1.7 Tue Feb 3 14:18:43 2004 +++ movitz/image.lisp Wed Feb 4 11:01:21 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.7 2004/02/03 19:18:43 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.8 2004/02/04 16:01:21 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1469,7 +1469,7 @@ , at toplevel-code (muerte::halt-cpu)) - nil t nil))) + nil t))) (defun mkasm-write-word-eax-ebx () (let ((loop-label (make-symbol "write-word-loop")) From ffjeld at common-lisp.net Wed Feb 4 16:01:28 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 04 Feb 2004 11:01:28 -0500 Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv32512 Modified Files: special-operators.lisp Log Message: Sync small edits. Date: Wed Feb 4 11:01:28 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.5 movitz/special-operators.lisp:1.6 --- movitz/special-operators.lisp:1.5 Tue Feb 3 14:17:34 2004 +++ movitz/special-operators.lisp Wed Feb 4 11:01:26 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.5 2004/02/03 19:17:34 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.6 2004/02/04 16:01:26 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -259,7 +259,7 @@ (declare (ignore c)) (format *error-output* "~&;; In function ~S:~&" name)))) (let* ((*compiling-function-name* name) - (funobj (make-compiled-funobj name formals declarations body env nil nil))) + (funobj (make-compiled-funobj name formals declarations body env nil))) (setf (movitz-funobj-symbolic-name funobj) name) (setf (movitz-env-named-function name) funobj)))) (compiler-values ())) From ffjeld at common-lisp.net Wed Feb 4 16:14:42 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Wed, 04 Feb 2004 11:14:42 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv31935 Modified Files: compiler.lisp Log Message: Factored out helper function ensure-pass1-funobj. Date: Wed Feb 4 11:14:42 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.13 movitz/compiler.lisp:1.14 --- movitz/compiler.lisp:1.13 Wed Feb 4 11:01:14 2004 +++ movitz/compiler.lisp Wed Feb 4 11:14:42 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.13 2004/02/04 16:01:14 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.14 2004/02/04 16:14:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -182,8 +182,15 @@ (t 'make-compiled-function-pass1)) name lambda-list declarations form env top-level-p funobj)))) +(defun ensure-pass1-funobj (funobj class &rest init-args) + "If funobj is nil, return a fresh funobj of class. +Otherwise coerce funobj to class." + (if funobj + (apply #'change-class funobj class init-args) + (apply #'make-instance class init-args))) + (defun make-compiled-function-pass1-numarg-case (name lambda-list declarations form env top-level-p funobj) - (let* ((funobj (or funobj (make-instance 'movitz-funobj-pass1-numargs-case))) + (let* ((funobj (ensure-pass1-funobj funobj 'movitz-funobj-pass1-numargs-case)) (funobj-env (make-local-movitz-environment env funobj :type 'funobj-env))) (setf (movitz-funobj-name funobj) name (movitz-funobj-lambda-list funobj) (movitz-read (lambda-list-simplify lambda-list)) @@ -204,11 +211,11 @@ (append clause-declarations declarations))))) (make-compiled-function-body-pass1 funobj - function-env - (list* 'muerte.cl::block - (compute-function-block-name name) - clause-body) - top-level-p) + function-env + (list* 'muerte.cl::block + (compute-function-block-name name) + clause-body) + top-level-p) (push (cons numargs function-env) (function-envs funobj))))) funobj)) @@ -217,7 +224,7 @@ "Returns funobj." (when (duplicatesp lambda-list) (error "There are duplicates in lambda-list ~S." lambda-list)) - (let* ((funobj (or funobj (make-instance 'movitz-funobj-pass1))) + (let* ((funobj (ensure-pass1-funobj funobj 'movitz-funobj-pass1)) (funobj-env (make-local-movitz-environment env funobj :type 'funobj-env)) (function-env (add-bindings-from-lambda-list lambda-list From ffjeld at common-lisp.net Thu Feb 5 10:45:21 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 05 Feb 2004 05:45:21 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv13337 Modified Files: compiler.lisp Log Message: Removed function make-compiled-function-body-pass1. Date: Thu Feb 5 05:45:20 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.14 movitz/compiler.lisp:1.15 --- movitz/compiler.lisp:1.14 Wed Feb 4 11:14:42 2004 +++ movitz/compiler.lisp Thu Feb 5 05:45: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.14 2004/02/04 16:14:42 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.15 2004/02/05 10:45:20 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -168,13 +168,13 @@ (multiple-value-bind (required-vars optional-vars rest-var key-vars) (decode-normal-lambda-list lambda-list) ;; There are several main branches through the function - ;; compiler, and this is where we decide which to take. + ;; compiler, and this is where we decide which one to take. (funcall (cond ((let ((sub-form (cddr form))) (and (consp (car sub-form)) (eq 'muerte::numargs-case (caar sub-form)))) 'make-compiled-function-pass1-numarg-case) - ((and (= 1 (length required-vars)) + ((and (= 1 (length required-vars)) ; (x &optional y) (= 1 (length optional-vars)) (null key-vars) (not rest-var)) @@ -201,21 +201,29 @@ (error "There are duplicates in lambda-list ~S." lambda-list)) (multiple-value-bind (clause-body clause-declarations) (parse-declarations-and-body clause-body) - (let ((function-env - (add-bindings-from-lambda-list lambda-list - (make-local-movitz-environment - funobj-env funobj - :type 'function-env - :declaration-context :funobj - :declarations - (append clause-declarations - declarations))))) - (make-compiled-function-body-pass1 funobj - function-env - (list* 'muerte.cl::block - (compute-function-block-name name) - clause-body) - top-level-p) + (let* ((function-env + (add-bindings-from-lambda-list lambda-list + (make-local-movitz-environment + funobj-env funobj + :type 'function-env + :declaration-context :funobj + :declarations + (append clause-declarations + declarations)))) + (function-form (list* 'muerte.cl::block + (compute-function-block-name name) + clause-body))) + (multiple-value-bind (arg-init-code need-normalized-ecx-p) + (make-function-arguments-init funobj function-env) + (setf (extended-code function-env) + (append arg-init-code + (compiler-call #'compile-form + :form (make-special-funarg-shadowing function-env function-form) + :funobj funobj + :env function-env + :top-level-p top-level-p + :result-mode :function))) + (setf (need-normalized-ecx-p function-env) need-normalized-ecx-p)) (push (cons numargs function-env) (function-envs funobj))))) funobj)) @@ -236,22 +244,19 @@ (movitz-funobj-lambda-list funobj) (movitz-read (lambda-list-simplify lambda-list)) (funobj-env funobj) funobj-env (function-envs funobj) (list (cons 'muerte.cl::t function-env))) - (make-compiled-function-body-pass1 funobj function-env form top-level-p))) - -(defun make-compiled-function-body-pass1 (funobj function-env form top-level-p) - "Returns the funobj with its extended-code." - (compiler-values-bind (&code body-code) - (compiler-call #'compile-form - :form (make-special-funarg-shadowing function-env form) - :funobj funobj - :env function-env - :top-level-p top-level-p - :result-mode :function) (multiple-value-bind (arg-init-code need-normalized-ecx-p) (make-function-arguments-init funobj function-env) - (setf (extended-code function-env) (append arg-init-code body-code) - (need-normalized-ecx-p function-env) need-normalized-ecx-p) - funobj))) + (setf (need-normalized-ecx-p function-env) need-normalized-ecx-p) + (setf (extended-code function-env) + (append arg-init-code + (compiler-call #'compile-form + :form (make-special-funarg-shadowing function-env form) + :funobj funobj + :env function-env + :top-level-p top-level-p + :result-mode :function)))) + funobj)) + (defun make-compiled-funobj-pass2 (toplevel-funobj-pass1) "This is where second pass compilation for each top-level funobj begins." From ffjeld at common-lisp.net Thu Feb 5 11:02:39 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 05 Feb 2004 06:02:39 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv11936 Modified Files: compiler.lisp Log Message: Changed ensure-pass1-funobj definition and usage, now utilizing init-args. Date: Thu Feb 5 06:02:39 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.15 movitz/compiler.lisp:1.16 --- movitz/compiler.lisp:1.15 Thu Feb 5 05:45:20 2004 +++ movitz/compiler.lisp Thu Feb 5 06:02:39 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.15 2004/02/05 10:45:20 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.16 2004/02/05 11:02:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -178,23 +178,25 @@ (= 1 (length optional-vars)) (null key-vars) (not rest-var)) - 'make-compiled-function-pass1) + 'make-compiled-function-pass1-1req1opt) (t 'make-compiled-function-pass1)) name lambda-list declarations form env top-level-p funobj)))) (defun ensure-pass1-funobj (funobj class &rest init-args) "If funobj is nil, return a fresh funobj of class. Otherwise coerce funobj to class." - (if funobj - (apply #'change-class funobj class init-args) - (apply #'make-instance class init-args))) + (apply #'reinitialize-instance + (if funobj + (change-class funobj class) + (make-instance class)) + init-args)) (defun make-compiled-function-pass1-numarg-case (name lambda-list declarations form env top-level-p funobj) - (let* ((funobj (ensure-pass1-funobj funobj 'movitz-funobj-pass1-numargs-case)) + (let* ((funobj (ensure-pass1-funobj funobj 'movitz-funobj-pass1-numargs-case + :name name + :lambda-list (movitz-read (lambda-list-simplify lambda-list)))) (funobj-env (make-local-movitz-environment env funobj :type 'funobj-env))) - (setf (movitz-funobj-name funobj) name - (movitz-funobj-lambda-list funobj) (movitz-read (lambda-list-simplify lambda-list)) - (funobj-env funobj) funobj-env + (setf (funobj-env funobj) funobj-env (function-envs funobj) nil) (loop for (numargs lambda-list . clause-body) in (cdr (caddr form)) do (when (duplicatesp lambda-list) @@ -232,7 +234,9 @@ "Returns funobj." (when (duplicatesp lambda-list) (error "There are duplicates in lambda-list ~S." lambda-list)) - (let* ((funobj (ensure-pass1-funobj funobj 'movitz-funobj-pass1)) + (let* ((funobj (ensure-pass1-funobj funobj 'movitz-funobj-pass1 + :name name + :lambda-list (movitz-read (lambda-list-simplify lambda-list)))) (funobj-env (make-local-movitz-environment env funobj :type 'funobj-env)) (function-env (add-bindings-from-lambda-list lambda-list @@ -240,9 +244,7 @@ :type 'function-env :declaration-context :funobj :declarations declarations)))) - (setf (movitz-funobj-name funobj) name - (movitz-funobj-lambda-list funobj) (movitz-read (lambda-list-simplify lambda-list)) - (funobj-env funobj) funobj-env + (setf (funobj-env funobj) funobj-env (function-envs funobj) (list (cons 'muerte.cl::t function-env))) (multiple-value-bind (arg-init-code need-normalized-ecx-p) (make-function-arguments-init funobj function-env) From ffjeld at common-lisp.net Thu Feb 5 14:19:36 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 05 Feb 2004 09:19:36 -0500 Subject: [movitz-cvs] CVS update: movitz/procfs-image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv27364 Modified Files: procfs-image.lisp Log Message: Added method image-movitz-to-lisp-object. Date: Thu Feb 5 09:19:36 2004 Author: ffjeld Index: movitz/procfs-image.lisp diff -u movitz/procfs-image.lisp:1.2 movitz/procfs-image.lisp:1.3 --- movitz/procfs-image.lisp:1.2 Mon Jan 19 06:23:41 2004 +++ movitz/procfs-image.lisp Thu Feb 5 09:19:36 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Aug 24 11:39:37 2001 ;;;; -;;;; $Id: procfs-image.lisp,v 1.2 2004/01/19 11:23:41 ffjeld Exp $ +;;;; $Id: procfs-image.lisp,v 1.3 2004/02/05 14:19:36 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -103,6 +103,26 @@ (defun register32 (register-name) (image-register32 *image* register-name)) + +(defmethod image-movitz-to-lisp-object ((image procfs-image) expr) + (etypecase expr + (cons (mapcar #'movitz-print expr)) + ((not movitz-object) + expr) + ((or movitz-nil movitz-constant-block) nil) + (movitz-symbol + (intern (movitz-print (movitz-symbol-name expr)))) + (movitz-string + (map 'string #'identity + (movitz-vector-symbolic-data expr))) + (movitz-fixnum + (movitz-fixnum-value expr)) + (movitz-vector + (map 'vector #'movitz-print (movitz-vector-symbolic-data expr))) + (movitz-cons + (cons (movitz-print (movitz-car expr)) + (movitz-print (movitz-cdr expr)))))) + (defmethod report-gdtr ((image bochs-image)) (assert (file-position (image-stream image) From ffjeld at common-lisp.net Thu Feb 5 14:46:03 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 05 Feb 2004 09:46:03 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv705 Modified Files: compiler.lisp Log Message: These changes are all about making the compiler smarter about functions whose lambda-list look like (x &optional y). Most such functions become about 20 bytes shorter. More importantly, they become branch-less, reducing the CPU-cycle-cost of this abstraction essentially zero. Date: Thu Feb 5 09:46:02 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.16 movitz/compiler.lisp:1.17 --- movitz/compiler.lisp:1.16 Thu Feb 5 06:02:39 2004 +++ movitz/compiler.lisp Thu Feb 5 09:46:02 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.16 2004/02/05 11:02:39 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.17 2004/02/05 14:46:02 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -119,14 +119,15 @@ :accessor function-envs) (funobj-env :initarg :funobj-env - :accessor funobj-env)) + :accessor funobj-env) + (entry-protocol + :initform :default + :initarg :entry-protocol + :reader funobj-entry-protocol)) (:documentation "This class is used for funobjs during the first compiler pass. Before the second pass, such objects will be change-class-ed to proper movitz-funobjs. This way, we ensure that no undue side-effects on the funobj occur during pass 1.")) -(defclass movitz-funobj-pass1-numargs-case (movitz-funobj-pass1) ()) -(defclass movitz-funobj-pass1-1req1opt (movitz-funobj-pass1) ()) - (defmethod print-object ((object movitz-funobj-pass1) stream) (print-unreadable-object (object stream :type t :identity t) (when (slot-boundp object 'name) @@ -165,8 +166,10 @@ ;; mutually recursive (lexically bound) functions. (with-retries-until-true (retry-pass1 "Retry first-pass compilation of ~S." name) ;; First-pass is mostly functional, so it can safely be restarted. - (multiple-value-bind (required-vars optional-vars rest-var key-vars) + (multiple-value-bind (required-vars optional-vars rest-var key-vars + aux-vars allow-p min max edx-var) (decode-normal-lambda-list lambda-list) + (declare (ignore aux-vars allow-p min max)) ;; There are several main branches through the function ;; compiler, and this is where we decide which one to take. (funcall (cond @@ -176,8 +179,11 @@ 'make-compiled-function-pass1-numarg-case) ((and (= 1 (length required-vars)) ; (x &optional y) (= 1 (length optional-vars)) + (movitz-constantp (nth-value 1 (decode-optional-formal (first optional-vars))) + env) (null key-vars) - (not rest-var)) + (not rest-var) + (not edx-var)) 'make-compiled-function-pass1-1req1opt) (t 'make-compiled-function-pass1)) name lambda-list declarations form env top-level-p funobj)))) @@ -192,7 +198,8 @@ init-args)) (defun make-compiled-function-pass1-numarg-case (name lambda-list declarations form env top-level-p funobj) - (let* ((funobj (ensure-pass1-funobj funobj 'movitz-funobj-pass1-numargs-case + (let* ((funobj (ensure-pass1-funobj funobj 'movitz-funobj-pass1 + :entry-protocol :numargs-case :name name :lambda-list (movitz-read (lambda-list-simplify lambda-list)))) (funobj-env (make-local-movitz-environment env funobj :type 'funobj-env))) @@ -230,6 +237,46 @@ (function-envs funobj))))) funobj)) +(defun make-compiled-function-pass1-1req1opt (name lambda-list declarations form env top-level-p funobj) + "Returns funobj." + (when (duplicatesp lambda-list) + (error "There are duplicates in lambda-list ~S." lambda-list)) + (let* ((funobj (ensure-pass1-funobj funobj 'movitz-funobj-pass1 + :entry-protocol :1req1opt + :name name + :lambda-list (movitz-read (lambda-list-simplify lambda-list)))) + (funobj-env (make-local-movitz-environment env funobj :type 'funobj-env)) + (function-env (add-bindings-from-lambda-list + lambda-list + (make-local-movitz-environment funobj-env funobj + :type 'function-env + :need-normalized-ecx-p nil + :declaration-context :funobj + :declarations declarations))) + (optional-env (make-local-movitz-environment function-env funobj + :type 'function-env))) + (setf (funobj-env funobj) funobj-env) + ;; (print-code 'arg-init-code arg-init-code) + (setf (extended-code optional-env) + (compiler-call #'compile-form + :form (optional-function-argument-init-form + (movitz-binding (first (optional-vars function-env)) function-env nil)) + :funobj funobj + :env optional-env + :result-mode :ebx)) + (setf (extended-code function-env) + (append #+ignore arg-init-code + (compiler-call #'compile-form + :form (make-special-funarg-shadowing function-env form) + :funobj funobj + :env function-env + :top-level-p top-level-p + :result-mode :function))) + (setf (function-envs funobj) + (list (cons 'muerte.cl::t function-env) + (cons :optional optional-env))) + funobj)) + (defun make-compiled-function-pass1 (name lambda-list declarations form env top-level-p funobj) "Returns funobj." (when (duplicatesp lambda-list) @@ -261,7 +308,7 @@ (defun make-compiled-funobj-pass2 (toplevel-funobj-pass1) - "This is where second pass compilation for each top-level funobj begins." + "This is the entry-poing for second pass compilation for each top-level funobj." (check-type toplevel-funobj-pass1 movitz-funobj-pass1) (let ((toplevel-funobj (change-class toplevel-funobj-pass1 'movitz-funobj))) (multiple-value-bind (toplevel-funobj function-binding-usage) @@ -476,6 +523,75 @@ funobj) (defun complete-funobj (funobj) + (case (funobj-entry-protocol funobj) + (:1req1opt + (complete-funobj-1req1opt funobj)) + (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) + +(defun complete-funobj-1req1opt (funobj) + (assert (= 2 (length (function-envs funobj)))) + (let* ((function-env (cdr (assoc 'muerte.cl::t (function-envs funobj)))) + (optional-env (cdr (assoc :optional (function-envs funobj)))) + (frame-map (frame-map function-env)) + (resolved-code (finalize-code (extended-code function-env) funobj frame-map)) + (resolved-optional-code (finalize-code (extended-code optional-env) funobj frame-map)) + (stack-frame-size (frame-map-size (frame-map function-env))) + (use-stack-frame-p (or (plusp stack-frame-size) + (tree-search resolved-code + '(:ebp :esp :call :leave)))) + (optional-stack-frame-p (tree-search resolved-optional-code + '(:ebp :esp :call :leave)))) + (assert (not optional-stack-frame-p)) + (let* ((stack-setup-size stack-frame-size) + (function-code + (let* ((req-binding (movitz-binding (first (required-vars function-env)) + function-env nil)) + (req-location (cdr (assoc req-binding frame-map))) + (opt-binding (movitz-binding (first (optional-vars function-env)) + function-env nil)) + (opt-location (cdr (assoc opt-binding frame-map)))) + (append `((:jmp (:edi ,(global-constant-offset 'trampoline-cl-dispatch-1or2)))) + '(entry%1op) + (unless (eql nil opt-location) + resolved-optional-code) + '(entry%2op) + (when use-stack-frame-p + +enter-stack-frame-code+) + '(start-stack-frame-setup) + (cond + ((and (eql 1 req-location) + (eql 2 opt-location)) + (decf stack-setup-size 2) + `((:pushl :eax) + (:pushl :ebx))) + ((and (eql 1 req-location) + (eql nil opt-location)) + (decf stack-setup-size 1) + `((:pushl :eax))) + ((and (member req-location '(nil :eax)) + (eql 1 opt-location)) + (decf stack-setup-size 1) + `((:pushl :ebx))) + ((and (member req-location '(nil :eax)) + (member opt-location '(nil :ebx))) + nil) + (t (error "Can't deal with req ~S opt ~S." + req-location opt-location))) + (make-stack-setup-code stack-setup-size) + resolved-code + (make-compiled-function-postlude funobj function-env + use-stack-frame-p))))) + (let ((optimized-function-code + (optimize-code function-code + :keep-labels (nconc (subseq (movitz-funobj-const-list funobj) + 0 (movitz-funobj-num-jumpers funobj)) + '(entry%1op entry%2op))))) + (assemble-funobj funobj optimized-function-code))))) + +(defun complete-funobj-default (funobj) (let ((code-specs (loop for (numargs . function-env) in (function-envs funobj) collecting @@ -506,7 +622,7 @@ (code2 (cdr (assoc 2 code-specs))) (code3 (cdr (assoc 3 code-specs))) (codet (cdr (assoc 'muerte.cl::t code-specs)))) - (assert codet () "A default numargs-case is required.") + (assert codet () "A default numargs-case is required.") ;; (format t "codet:~{~&~A~}" codet) (let ((combined-code (delete 'start-stack-frame-setup @@ -539,8 +655,6 @@ codet))))) ;; (warn "opt code: ~{~&~A~}" optimized-function-code) (assemble-funobj funobj combined-code)))) - (loop for (sub-function-binding) on (sub-function-binding-usage funobj) by #'cddr - do (complete-funobj (function-binding-funobj sub-function-binding))) funobj) @@ -598,7 +712,8 @@ :initial-contents code-vector :flags '(:code-vector-p) :alignment 16 - :alignment-offset 8))))) + :alignment-offset 8)))) + funobj) #+ignore (defun make-compiled-function-body-default (form funobj env top-level-p) @@ -985,7 +1100,7 @@ (defun print-code (x code) (let ((*print-level* 3)) - (format t "~A code:~{~& ~A~}" x code)) + (format t "~&~A code:~{~& ~A~}" x code)) code) (defun layout-program (pc) @@ -3128,6 +3243,14 @@ (t (error "Don't know how to compile checking for ~A to ~A arguments." min-args max-args))))) +(defun make-stack-setup-code (stack-setup-size) + (case stack-setup-size + (0 nil) + (1 '((:pushl :edi))) + (2 '((:pushl :edi) (:pushl :edi))) + (3 '((:pushl :edi) (:pushl :edi) (:pushl :edi))) + (t `((:subl ,(* 4 stack-setup-size) :esp))))) + (defun make-compiled-function-prelude (stack-frame-size env use-stack-frame-p need-normalized-ecx-p frame-map &key do-check-stack-p) @@ -3258,7 +3381,7 @@ (append (when (and do-check-stack-p *compiler-auto-stack-checks-p* (not (without-check-stack-limit-p env))) - `(((:fs-override) + `((,*compiler-global-segment-prefix* :bound (:edi ,(global-constant-offset 'stack-bottom)) :esp))) (when use-stack-frame-p `((:pushl :ebp) @@ -3286,12 +3409,7 @@ (make-compiled-function-prelude-numarg-check min-args max-args)))) '(start-stack-frame-setup) eax-ebx-code - (case stack-setup-size - (0 nil) - (1 '((:pushl :edi))) - (2 '((:pushl :edi) (:pushl :edi))) - (3 '((:pushl :edi) (:pushl :edi) (:pushl :edi))) - (t `((:subl ,(* 4 stack-setup-size) :esp)))) + (make-stack-setup-code stack-setup-size) (when need-normalized-ecx-p (cond ;; normalize arg-count in ecx.. From ffjeld at common-lisp.net Thu Feb 5 14:46:08 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 05 Feb 2004 09:46:08 -0500 Subject: [movitz-cvs] CVS update: movitz/environment.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv13332 Modified Files: environment.lisp Log Message: These changes are all about making the compiler smarter about functions whose lambda-list look like (x &optional y). Most such functions become about 20 bytes shorter. More importantly, they become branch-less, reducing the CPU-cycle-cost of this abstraction essentially zero. Date: Thu Feb 5 09:46:08 2004 Author: ffjeld Index: movitz/environment.lisp diff -u movitz/environment.lisp:1.2 movitz/environment.lisp:1.3 --- movitz/environment.lisp:1.2 Fri Jan 16 14:45:36 2004 +++ movitz/environment.lisp Thu Feb 5 09:46:08 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.2 2004/01/16 19:45:36 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.3 2004/02/05 14:46:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -160,6 +160,7 @@ :initform nil :accessor key-vars) (need-normalized-ecx-p + :initarg :need-normalized-ecx-p :accessor need-normalized-ecx-p) (frame-map :accessor frame-map) From ffjeld at common-lisp.net Thu Feb 5 14:46:13 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 05 Feb 2004 09:46:13 -0500 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv24257 Modified Files: image.lisp Log Message: These changes are all about making the compiler smarter about functions whose lambda-list look like (x &optional y). Most such functions become about 20 bytes shorter. More importantly, they become branch-less, reducing the CPU-cycle-cost of this abstraction essentially zero. Date: Thu Feb 5 09:46:13 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.8 movitz/image.lisp:1.9 --- movitz/image.lisp:1.8 Wed Feb 4 11:01:21 2004 +++ movitz/image.lisp Thu Feb 5 09:46:13 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.8 2004/02/04 16:01:21 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.9 2004/02/05 14:46:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -253,6 +253,12 @@ :map-binary-read-delayed 'movitz-word-code-vector :binary-tag :primitive-function) (fast-compare-real-fixnum + :binary-type code-vector-word + :initform nil + :map-binary-write 'movitz-intern-code-vector + :map-binary-read-delayed 'movitz-word-code-vector + :binary-tag :primitive-function) + (trampoline-cl-dispatch-1or2 :binary-type code-vector-word :initform nil :map-binary-write 'movitz-intern-code-vector From ffjeld at common-lisp.net Thu Feb 5 14:46:19 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 05 Feb 2004 09:46:19 -0500 Subject: [movitz-cvs] CVS update: movitz/storage-types.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv4321 Modified Files: storage-types.lisp Log Message: These changes are all about making the compiler smarter about functions whose lambda-list look like (x &optional y). Most such functions become about 20 bytes shorter. More importantly, they become branch-less, reducing the CPU-cycle-cost of this abstraction essentially zero. Date: Thu Feb 5 09:46:19 2004 Author: ffjeld Index: movitz/storage-types.lisp diff -u movitz/storage-types.lisp:1.4 movitz/storage-types.lisp:1.5 --- movitz/storage-types.lisp:1.4 Wed Feb 4 10:25:28 2004 +++ movitz/storage-types.lisp Thu Feb 5 09:46:19 2004 @@ -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.4 2004/02/04 15:25:28 ffjeld Exp $ +;;;; $Id: storage-types.lisp,v 1.5 2004/02/05 14:46:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -835,7 +835,11 @@ :accessor movitz-funobj-usage) (sub-function-binding-usage ; a plist used during lexical analysis :initform nil - :accessor sub-function-binding-usage)) + :accessor sub-function-binding-usage) + (entry-protocol + :initform :default + :initarg :entry-protocol + :reader funobj-entry-protocol)) (:slot-align type -2)) (defmethod write-binary-record ((obj movitz-funobj) stream) From ffjeld at common-lisp.net Thu Feb 5 14:46:24 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Thu, 05 Feb 2004 09:46:24 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/primitive-functions.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv13331 Modified Files: primitive-functions.lisp Log Message: These changes are all about making the compiler smarter about functions whose lambda-list look like (x &optional y). Most such functions become about 20 bytes shorter. More importantly, they become branch-less, reducing the CPU-cycle-cost of this abstraction essentially zero. Date: Thu Feb 5 09:46:24 2004 Author: ffjeld Index: movitz/losp/muerte/primitive-functions.lisp diff -u movitz/losp/muerte/primitive-functions.lisp:1.2 movitz/losp/muerte/primitive-functions.lisp:1.3 --- movitz/losp/muerte/primitive-functions.lisp:1.2 Mon Jan 19 06:23:47 2004 +++ movitz/losp/muerte/primitive-functions.lisp Thu Feb 5 09:46:24 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Oct 2 21:02:18 2001 ;;;; -;;;; $Id: primitive-functions.lisp,v 1.2 2004/01/19 11:23:47 ffjeld Exp $ +;;;; $Id: primitive-functions.lisp,v 1.3 2004/02/05 14:46:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -45,6 +45,19 @@ ;;; (:movb 2 :cl) (:movb 3 :cl) (:jmp (:esi -6)))) + +(define-primitive-function trampoline-cl-dispatch-1or2 () + "Jump to the entry-point designated by :cl, which must be 1 or 2." + (with-inline-assembly (:returns :nothing) + (:cmpb 1 :cl) + (:jne 'not-one) + (:jmp (:esi #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector%1op))) + not-one + (:cmpb 2 :cl) + (:jne 'not-two) + (:jmp (:esi #.(bt:slot-offset 'movitz:movitz-funobj 'movitz:code-vector%2op))) + not-two + (:int 100))) (define-primitive-function no-code-vector () "This is the default code-vector, which never should be called." From ffjeld at common-lisp.net Sun Feb 8 22:35:12 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 08 Feb 2004 17:35:12 -0500 Subject: [movitz-cvs] CVS update: ia-x86/codec.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv4832 Modified Files: codec.lisp Log Message: Changed indenting style of defclass forms. Date: Sun Feb 8 17:35:12 2004 Author: ffjeld Index: ia-x86/codec.lisp diff -u ia-x86/codec.lisp:1.2 ia-x86/codec.lisp:1.3 --- ia-x86/codec.lisp:1.2 Fri Jan 16 06:54:14 2004 +++ ia-x86/codec.lisp Sun Feb 8 17:35:11 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu May 4 15:16:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: codec.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: codec.lisp,v 1.3 2004/02/08 22:35:11 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -39,75 +39,94 @@ (defclass template () - ((value :type unsigned-byte - :initarg value - :accessor template-value) - (numo :type (integer 1 12) - :initarg numo - :accessor template-numo) - (priority :type integer - :initarg priority - :initform +template-default-priority+ - :accessor template-priority))) + ((value + :type unsigned-byte + :initarg value + :accessor template-value) + (numo + :type (integer 1 12) + :initarg numo + :accessor template-numo) + (priority + :type integer + :initarg priority + :initform +template-default-priority+ + :accessor template-priority))) (defclass instr-template (template) - ((mask :type signed-byte - :initarg mask - :accessor template-mask) - (not-list :type list ; list of value/masks that must *not* match. - :initform '() - :initarg not-list - :accessor template-not-list) - (cpu-mode :type (member :32-bit :16-bit :any-mode) - :initform :any-mode - :initarg cpu-mode - :accessor template-cpu-mode) - (operand-mode :type (member :32-bit :16-bit :any-mode) - :initform :any-mode - :initarg operand-mode - :accessor template-operand-mode) - (addressing-mode :type (member :32-bit :16-bit :any-mode) - :initform :any-mode - :initarg addressing-mode - :accessor template-addressing-mode) - (req-prefixes :type list ; list of prefixes required for a match - :initform '() - :initarg req-prefixes - :accessor template-req-prefixes) - (not-prefixes :type list ; list of prefixes disqualifying any match - :initform '() - :initarg not-prefixes - :accessor template-not-prefixes) - (instr-classname :initarg instr-classname - :accessor template-instr-classname) - (instr-numo :type (integer 1 16) - :initarg instr-numo - :accessor template-instr-numo) - (instr-operand-types :type list - :initarg instr-operand-types - :accessor template-instr-operand-types) - (instr-operand-classes :type list ; this template generates operands of these classes (in this order) - :initarg instr-operand-classes - :accessor template-instr-operand-classes) + ((mask + :type signed-byte + :initarg mask + :accessor template-mask) + (not-list + :type list ; list of value/masks that must *not* match. + :initform '() + :initarg not-list + :accessor template-not-list) + (cpu-mode + :type (member :32-bit :16-bit :any-mode) + :initform :any-mode + :initarg cpu-mode + :accessor template-cpu-mode) + (operand-mode + :type (member :32-bit :16-bit :any-mode) + :initform :any-mode + :initarg operand-mode + :accessor template-operand-mode) + (addressing-mode + :type (member :32-bit :16-bit :any-mode) + :initform :any-mode + :initarg addressing-mode + :accessor template-addressing-mode) + (req-prefixes + :type list ; list of prefixes required for a match + :initform '() + :initarg req-prefixes + :accessor template-req-prefixes) + (not-prefixes + :type list ; list of prefixes disqualifying any match + :initform '() + :initarg not-prefixes + :accessor template-not-prefixes) + (instr-classname + :initarg instr-classname + :accessor template-instr-classname) + (instr-numo + :type (integer 1 16) + :initarg instr-numo + :accessor template-instr-numo) + (instr-operand-types + :type list + :initarg instr-operand-types + :accessor template-instr-operand-types) + (instr-operand-classes + :type list ; this template generates operands of these classes (in this order) + :initarg instr-operand-classes + :accessor template-instr-operand-classes) (instr-operand-base-classes :type list ; caching the base-classes of instr-operand-classes :initarg instr-operand-base-classes :accessor template-instr-operand-base-classes) - (instr-modr/m-p :type boolean ; does instruction have modr/m? - :initarg modr/m-p - :accessor template-instr-modr/m-p) - (instr-sib-p :type boolean ; does instruction have SIB? - :initarg sib-p - :accessor template-instr-sib-p) - (instr-displacement-numo :type (integer 0 4) ; size of "displacement" field. - :initarg displacement-numo - :accessor template-instr-displacement-numo) - (instr-immediate-numo :type (integer 0 4) ; size of "immediate" field. - :initarg immediate-numo - :accessor template-instr-immediate-numo) - (instr-opcode-numo :type (integer 1 2) ; size of "opcode" field. - :initarg opcode-numo - :accessor template-instr-opcode-numo))) + (instr-modr/m-p + :type boolean ; does instruction have modr/m? + :initarg modr/m-p + :accessor template-instr-modr/m-p) + (instr-sib-p + :type boolean ; does instruction have SIB? + :initarg sib-p + :accessor template-instr-sib-p) + (instr-displacement-numo + :type (integer 0 4) ; size of "displacement" field. + :initarg displacement-numo + :accessor template-instr-displacement-numo) + (instr-immediate-numo + :type (integer 0 4) ; size of "immediate" field. + :initarg immediate-numo + :accessor template-instr-immediate-numo) + (instr-opcode-numo + :type (integer 1 2) ; size of "opcode" field. + :initarg opcode-numo + :accessor template-instr-opcode-numo))) (defmethod print-object ((obj instr-template) stream) (if *print-pretty* @@ -125,7 +144,8 @@ (call-next-method obj stream))) (defclass prefix-template (template) - ((value :type (unsigned-byte 8)))) + ((value + :type (unsigned-byte 8)))) (defmethod template-numo ((template prefix-template)) (values 1)) From ffjeld at common-lisp.net Sun Feb 8 22:38:35 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 08 Feb 2004 17:38:35 -0500 Subject: [movitz-cvs] CVS update: ia-x86/codec.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv19649 Modified Files: codec.lisp Log Message: Changed :type declaration of instr-opcode-numo of class instr-template, because there are indeed instructions longer than 2 bytes. Date: Sun Feb 8 17:38:35 2004 Author: ffjeld Index: ia-x86/codec.lisp diff -u ia-x86/codec.lisp:1.3 ia-x86/codec.lisp:1.4 --- ia-x86/codec.lisp:1.3 Sun Feb 8 17:35:11 2004 +++ ia-x86/codec.lisp Sun Feb 8 17:38:35 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu May 4 15:16:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: codec.lisp,v 1.3 2004/02/08 22:35:11 ffjeld Exp $ +;;;; $Id: codec.lisp,v 1.4 2004/02/08 22:38:35 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -124,7 +124,7 @@ :initarg immediate-numo :accessor template-instr-immediate-numo) (instr-opcode-numo - :type (integer 1 2) ; size of "opcode" field. + :type (integer 1 16) ; size of "opcode" field. :initarg opcode-numo :accessor template-instr-opcode-numo))) From ffjeld at common-lisp.net Sun Feb 8 23:06:00 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 08 Feb 2004 18:06:00 -0500 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22657 Modified Files: packages.lisp Log Message: Added some defvar names to the movitz package. Date: Sun Feb 8 18:05:59 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.2 movitz/packages.lisp:1.3 --- movitz/packages.lisp:1.2 Mon Feb 2 08:06:39 2004 +++ movitz/packages.lisp Sun Feb 8 18:05:59 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.2 2004/02/02 13:06:39 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.3 2004/02/08 23:05:59 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1284,7 +1284,15 @@ movitz-read-and-intern movitz-word word - + + #:*warn-function-change-p* + #:*compiler-do-optimize* + #:*compiler-use-cmov-p* + #:*compiler-auto-stack-checks-p* + #:*compiler-local-segment-prefix* + #:*compiler-global-segment-prefix* + #:*compiler-compile-eval-whens* + #:*compiler-compile-macro-expanders* ) (:import-from muerte #:translate-program From ffjeld at common-lisp.net Sun Feb 8 23:24:13 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 08 Feb 2004 18:24:13 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv22384 Modified Files: compiler.lisp Log Message: Two things: 1. Make movitz-macro-expander-make-function work consistently (return the function's name). 2. Support the supplied-p-parameter for the optimized compilation of (x &optional (y init supplied-p)). Date: Sun Feb 8 18:24:13 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.17 movitz/compiler.lisp:1.18 --- movitz/compiler.lisp:1.17 Thu Feb 5 09:46:02 2004 +++ movitz/compiler.lisp Sun Feb 8 18:24:13 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.17 2004/02/05 14:46:02 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.18 2004/02/08 23:24:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -135,11 +135,14 @@ object) (defun movitz-macro-expander-make-function (lambda-form &key name (type :unknown)) - "Make a lambda-form that is a macro-expander into a proper function." - (if *compiler-compile-macro-expanders* - (compile (gensym (format nil "~A-expander-~@[~A-~]" type name)) - lambda-form) - (coerce lambda-form 'function))) + "Make a lambda-form that is a macro-expander into a proper function. +Gensym a name whose symbol-function is set to the macro-expander, and return that symbol." + (let ((function-name (gensym (format nil "~A-expander-~@[~A-~]" type name)))) + (if *compiler-compile-macro-expanders* + (compile function-name lambda-form) + (setf (symbol-function function-name) + (coerce lambda-form 'function))) + function-name)) (defun make-compiled-funobj (name lambda-list declarations form env top-level-p &key funobj) "Compiler entry-point for making a (lexically) top-level function." @@ -349,12 +352,12 @@ (loop for function-binding in (sub-function-binding-usage funobj) by #'cddr do (analyze-funobj (function-binding-funobj function-binding))) funobj)) - #+ignore (analyze-funobj toplevel-funobj) - #+ignore (dolist (binding bindings) - (let ((types (binding-store-type binding))) - (unless (some #'type-is-t types) - (warn "binding: ~S~% types: ~S" - binding types)))) +;;; (analyze-funobj toplevel-funobj) +;;; (dolist (binding bindings) +;;; (let ((types (binding-store-type binding))) +;;; (when (or t (notany #'type-is-t types)) +;;; (warn "binding: ~S~% types: ~S" +;;; binding types)))) toplevel-funobj))) (defun resolve-borrowed-bindings (toplevel-funobj) @@ -545,42 +548,60 @@ (optional-stack-frame-p (tree-search resolved-optional-code '(:ebp :esp :call :leave)))) (assert (not optional-stack-frame-p)) - (let* ((stack-setup-size stack-frame-size) - (function-code + (let* ((function-code (let* ((req-binding (movitz-binding (first (required-vars function-env)) function-env nil)) (req-location (cdr (assoc req-binding frame-map))) (opt-binding (movitz-binding (first (optional-vars function-env)) function-env nil)) - (opt-location (cdr (assoc opt-binding frame-map)))) + (opt-location (cdr (assoc opt-binding frame-map))) + (optp-binding (movitz-binding (optional-function-argument-supplied-p-var opt-binding) + function-env nil)) + (optp-location (cdr (assoc optp-binding frame-map))) + (stack-setup-pre 0)) (append `((:jmp (:edi ,(global-constant-offset 'trampoline-cl-dispatch-1or2)))) '(entry%1op) (unless (eql nil opt-location) resolved-optional-code) + (when optp-location + `((:movl :edi :ecx) + (:jmp 'optp-into-ecx-ok))) '(entry%2op) + (when optp-location + `((,*compiler-global-segment-prefix* + :movl (:edi ,(global-constant-offset 't-symbol)) :ecx) + optp-into-ecx-ok)) (when use-stack-frame-p +enter-stack-frame-code+) '(start-stack-frame-setup) (cond ((and (eql 1 req-location) (eql 2 opt-location)) - (decf stack-setup-size 2) + (incf stack-setup-pre 2) `((:pushl :eax) (:pushl :ebx))) ((and (eql 1 req-location) (eql nil opt-location)) - (decf stack-setup-size 1) + (incf stack-setup-pre 1) `((:pushl :eax))) ((and (member req-location '(nil :eax)) (eql 1 opt-location)) - (decf stack-setup-size 1) + (incf stack-setup-pre 1) `((:pushl :ebx))) ((and (member req-location '(nil :eax)) (member opt-location '(nil :ebx))) nil) (t (error "Can't deal with req ~S opt ~S." req-location opt-location))) - (make-stack-setup-code stack-setup-size) + (cond + ((not optp-location) + ()) + ((= optp-location (1+ stack-setup-pre)) + (incf stack-setup-pre 1) + `((:pushl :ecx))) + (t (error "Can't deal with optional-p at ~S, after (~S ~S)." + optp-location req-location opt-location))) + (make-stack-setup-code (- stack-frame-size stack-setup-pre)) resolved-code (make-compiled-function-postlude funobj function-env use-stack-frame-p))))) From ffjeld at common-lisp.net Sun Feb 8 23:27:56 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Sun, 08 Feb 2004 18:27:56 -0500 Subject: [movitz-cvs] CVS update: movitz/special-operators.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv3749 Modified Files: special-operators.lisp Log Message: Provide name for gensym of setf-expanders. Date: Sun Feb 8 18:27:56 2004 Author: ffjeld Index: movitz/special-operators.lisp diff -u movitz/special-operators.lisp:1.6 movitz/special-operators.lisp:1.7 --- movitz/special-operators.lisp:1.6 Wed Feb 4 11:01:26 2004 +++ movitz/special-operators.lisp Sun Feb 8 18:27:56 2004 @@ -8,7 +8,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Fri Nov 24 16:22:59 2000 ;;;; -;;;; $Id: special-operators.lisp,v 1.6 2004/02/04 16:01:26 ffjeld Exp $ +;;;; $Id: special-operators.lisp,v 1.7 2004/02/08 23:27:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -359,7 +359,7 @@ (values-list (translate-program (multiple-value-list (block ,access-fn , at cl-body)) :cl :muerte.cl))))))) - (movitz-macro-expander-make-function expander :type :setf))))))) + (movitz-macro-expander-make-function expander :type :setf :name access-fn))))))) (compiler-values ())) (define-special-operator muerte::defmacro-compile-time (&form form) @@ -977,12 +977,15 @@ :form term-form) (assert term2-type) (let ((term2-type (type-specifier-primary term2-type))) +;;; (warn "t2-type: ~S, t2-ret: ~S, rm: ~S" +;;; term2-type term2-returns result-mode) (case term2-returns (:untagged-fixnum-eax (case result-mode (:untagged-fixnum-eax (compiler-values () :returns :untagged-fixnum-eax + :type 'integer :functional-p term2-functional-p :modifies term2-modifies :code (append term2-code @@ -1009,20 +1012,23 @@ :returns add-register :functional-p term2-functional-p :modifies term2-modifies + :type 'integer :code (append new-load-term-code - (unless nil #+ignore (subtypep (translate-program term2-type :muerte.cl :cl) - `(integer ,+movitz-most-negative-fixnum+ - ,+movitz-most-positive-fixnum+)) + (unless nil + #+ignore (subtypep (translate-program term2-type :muerte.cl :cl) + `(integer ,+movitz-most-negative-fixnum+ + ,+movitz-most-positive-fixnum+)) `((:testb ,+movitz-fixnum-zmask+ ,(register32-to-low8 add-register)) (:jnz '(:sub-program (,label) (:int 107) (:jmp (:pc+ -4)))))) `((:addl ,(* constant-term +movitz-fixnum-factor+) ,add-register)) - (unless nil #+ignore (subtypep (translate-program term2-type :muerte.cl :cl) - `(integer ,(+ +movitz-most-negative-fixnum+ - constant-term) - ,(+ +movitz-most-positive-fixnum+ - constant-term))) + (unless nil + #+ignore (subtypep (translate-program term2-type :muerte.cl :cl) + `(integer ,(+ +movitz-most-negative-fixnum+ + constant-term) + ,(+ +movitz-most-positive-fixnum+ + constant-term))) '((:into))))))))))))) (cond ((and (movitz-constantp term1 env) From ffjeld at common-lisp.net Mon Feb 9 23:41:14 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 18:41:14 -0500 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30535 Modified Files: image.lisp Log Message: Fixed the dumping of package objects so as to not rely on the ability to access defstruct objects with slot-value. This to accommodate CMUCL. Date: Mon Feb 9 18:41:13 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.9 movitz/image.lisp:1.10 --- movitz/image.lisp:1.9 Thu Feb 5 09:46:13 2004 +++ movitz/image.lisp Mon Feb 9 18:41:13 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.9 2004/02/05 14:46:13 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.10 2004/02/09 23:41:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1005,16 +1005,15 @@ :name package-name :shadowing-symbols-list (package-shadowing-symbols lisp-package) :external-symbols (make-hash-table :test #'equal) - :internal-symbols (make-hash-table :test #'equal)))) + :internal-symbols (make-hash-table :test #'equal) + :use-list (mapcar #'(lambda (up) + (ensure-package (movitz-package-name (package-name up)) up)) + (package-use-list lisp-package))))) (setf (gethash package-name packages-hash) p) - (setf (slot-value p 'muerte::use-list) - (mapcar #'(lambda (up) - (ensure-package (movitz-package-name (package-name up)) up)) - (package-use-list lisp-package))) p))))) - (let ((cl-package (ensure-package (symbol-name :common-lisp) - (find-package :muerte.common-lisp)))) - (setf (gethash "NIL" (slot-value cl-package 'muerte::external-symbols)) + (let ((movitz-cl-package (ensure-package (symbol-name :common-lisp) + (find-package :muerte.common-lisp)))) + (setf (gethash "NIL" (funcall 'muerte:package-object-external-symbols movitz-cl-package)) nil)) (loop for symbol being the hash-key of (image-oblist *image*) as lisp-package = (symbol-package symbol) @@ -1027,12 +1026,12 @@ (ecase status (:internal (setf (gethash (symbol-name symbol) - (slot-value movitz-package 'muerte::internal-symbols)) + (funcall 'muerte:package-object-internal-symbols movitz-package)) symbol)) (:external ;; (warn "putting external ~S in ~S" symbol package-name) (setf (gethash (symbol-name symbol) - (slot-value movitz-package 'muerte::external-symbols)) + (funcall 'muerte:package-object-external-symbols movitz-package)) symbol)) (:inherited (warn "inherited symbol: ~S" symbol)))))) From ffjeld at common-lisp.net Mon Feb 9 23:42:18 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 18:42:18 -0500 Subject: [movitz-cvs] CVS update: movitz/packages.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv10272 Modified Files: packages.lisp Log Message: Added some package-object symbols to the muerte package. Date: Mon Feb 9 18:42:18 2004 Author: ffjeld Index: movitz/packages.lisp diff -u movitz/packages.lisp:1.3 movitz/packages.lisp:1.4 --- movitz/packages.lisp:1.3 Sun Feb 8 18:05:59 2004 +++ movitz/packages.lisp Mon Feb 9 18:42:18 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Sat Nov 15 21:39:55 2003 ;;;; -;;;; $Id: packages.lisp,v 1.3 2004/02/08 23:05:59 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.4 2004/02/09 23:42:18 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1114,6 +1114,10 @@ *error-no-condition-for-debugger* formatted-error + + #:package-object-use-list + #:package-object-internal-symbols + #:package-object-external-symbols vector-element-type vector-element-size From ffjeld at common-lisp.net Mon Feb 9 23:46:23 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 18:46:23 -0500 Subject: [movitz-cvs] CVS update: ia-x86/operands.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv3751 Modified Files: operands.lisp Log Message: Reformatted some defclass forms, and removed some type-declarations that are more likely to break things than being helpful in any way. Date: Mon Feb 9 18:46:23 2004 Author: ffjeld Index: ia-x86/operands.lisp diff -u ia-x86/operands.lisp:1.2 ia-x86/operands.lisp:1.3 --- ia-x86/operands.lisp:1.2 Fri Jan 16 06:54:14 2004 +++ ia-x86/operands.lisp Mon Feb 9 18:46:23 2004 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 20012000, 2002-2003, +;;;; Copyright (C) 20012000, 2002-2004, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: operands.lisp @@ -9,7 +9,7 @@ ;;;; Created at: Wed Feb 16 14:02:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: operands.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: operands.lisp,v 1.3 2004/02/09 23:46:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -186,9 +186,10 @@ (setf (cdr x) x))))) ; make circular one-list. (defclass operand-number (abstract-operand) - ((number :type integer - :initarg number - :reader operand-number))) + ((number + :type integer + :initarg number + :reader operand-number))) (defmethod operand-listform ((operand operand-number)) (list* 'quote @@ -207,9 +208,9 @@ ;;; ---------------------------------------------------------------- (defclass operand-immediate (concrete-operand) - ((value :type (unsigned-byte 32) - :initarg value - :accessor operand-value))) + ((value + :initarg value + :accessor operand-value))) (defmethod operand-listform ((obj operand-immediate)) (operand-value obj)) @@ -280,7 +281,6 @@ (defclass operand-rel-pointer (operand-memory) ((offset - :type (signed-byte 32) :accessor operand-offset :initarg offset))) From ffjeld at common-lisp.net Mon Feb 9 23:57:27 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 18:57:27 -0500 Subject: [movitz-cvs] CVS update: ia-x86/assemble.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv26689 Removed Files: assemble.lisp Log Message: Removed this dead, empty file from CVS. Date: Mon Feb 9 18:57:27 2004 Author: ffjeld From ffjeld at common-lisp.net Tue Feb 10 00:03:10 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:03:10 -0500 Subject: [movitz-cvs] CVS update: ia-x86/alignment.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv11614 Modified Files: alignment.lisp Log Message: Designate the ia-x86 package with #:ia-x86 rather than "IA-X86". Also, a few very minor edits. Date: Mon Feb 9 19:03:09 2004 Author: ffjeld Index: ia-x86/alignment.lisp diff -u ia-x86/alignment.lisp:1.2 ia-x86/alignment.lisp:1.3 --- ia-x86/alignment.lisp:1.2 Fri Jan 16 06:54:14 2004 +++ ia-x86/alignment.lisp Mon Feb 9 19:03:09 2004 @@ -10,11 +10,11 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Wed Apr 10 12:47:08 2002 ;;;; -;;;; $Id: alignment.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: alignment.lisp,v 1.3 2004/02/10 00:03:09 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(in-package "IA-X86") +(in-package #:ia-x86) (defclass alignment () ((type From ffjeld at common-lisp.net Tue Feb 10 00:03:15 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:03:15 -0500 Subject: [movitz-cvs] CVS update: ia-x86/codec.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv23712 Modified Files: codec.lisp Log Message: Designate the ia-x86 package with #:ia-x86 rather than "IA-X86". Also, a few very minor edits. Date: Mon Feb 9 19:03:14 2004 Author: ffjeld Index: ia-x86/codec.lisp diff -u ia-x86/codec.lisp:1.4 ia-x86/codec.lisp:1.5 --- ia-x86/codec.lisp:1.4 Sun Feb 8 17:38:35 2004 +++ ia-x86/codec.lisp Mon Feb 9 19:03:14 2004 @@ -9,11 +9,11 @@ ;;;; Created at: Thu May 4 15:16:45 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: codec.lisp,v 1.4 2004/02/08 22:38:35 ffjeld Exp $ +;;;; $Id: codec.lisp,v 1.5 2004/02/10 00:03:14 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(in-package "IA-X86") +(in-package #:ia-x86) (defparameter *error-on-eof* nil) (defparameter *error-on-unknown-instruction* nil) @@ -23,7 +23,7 @@ ;;; ---------------------------------------------------------------- ;;; A "template" is an object that is used to map op-codes to -;;; instructions. The basic problem it solves is that IA-X86 uses +;;; instructions. The basic problem it solves is that ia-x86 uses ;;; variable-length op-codes. Consequently, figuring out if the ;;; octets you are currently decoding represents a complete op-code ;;; is non-trivial. From ffjeld at common-lisp.net Tue Feb 10 00:03:19 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:03:19 -0500 Subject: [movitz-cvs] CVS update: ia-x86/def-instr.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv31266 Modified Files: def-instr.lisp Log Message: Designate the ia-x86 package with #:ia-x86 rather than "IA-X86". Also, a few very minor edits. Date: Mon Feb 9 19:03:19 2004 Author: ffjeld Index: ia-x86/def-instr.lisp diff -u ia-x86/def-instr.lisp:1.2 ia-x86/def-instr.lisp:1.3 --- ia-x86/def-instr.lisp:1.2 Fri Jan 16 06:54:14 2004 +++ ia-x86/def-instr.lisp Mon Feb 9 19:03:19 2004 @@ -8,11 +8,11 @@ ;;;; Created at: Thu May 4 16:41:20 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: def-instr.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: def-instr.lisp,v 1.3 2004/02/10 00:03:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(in-package "IA-X86") +(in-package #:ia-x86) (defvar *instr-definitions* (make-hash-table)) @@ -28,8 +28,8 @@ collect (make-instr-template instr-spec)))) (templates-remember name templates))) *instr-definitions*) - (table-stats "IA-X86: " *template-table*) - (table-stats "IA-X86 2op: " *template-table-0f*)) + (table-stats "ia-x86: " *template-table*) + (table-stats "ia-x86 2op: " *template-table-0f*)) (defun make-instr-template (instr-spec) (destructuring-bind (base-class From ffjeld at common-lisp.net Tue Feb 10 00:03:24 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:03:24 -0500 Subject: [movitz-cvs] CVS update: ia-x86/ia-x86.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv7456 Modified Files: ia-x86.lisp Log Message: Designate the ia-x86 package with #:ia-x86 rather than "IA-X86". Also, a few very minor edits. Date: Mon Feb 9 19:03:24 2004 Author: ffjeld Index: ia-x86/ia-x86.lisp diff -u ia-x86/ia-x86.lisp:1.2 ia-x86/ia-x86.lisp:1.3 --- ia-x86/ia-x86.lisp:1.2 Fri Jan 16 06:54:14 2004 +++ ia-x86/ia-x86.lisp Mon Feb 9 19:03:23 2004 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 200120001999, 2002, +;;;; Copyright (C) 200120001999, 2002, 2004, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: ia-x86.lisp @@ -9,11 +9,11 @@ ;;;; Created at: Fri Dec 17 18:01:26 1999 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: ia-x86.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: ia-x86.lisp,v 1.3 2004/02/10 00:03:23 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(in-package "IA-X86") +(in-package #:ia-x86) ;;; ---------------------------------------------------------------- ;;; Instruction Definition From ffjeld at common-lisp.net Tue Feb 10 00:03:30 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:03:30 -0500 Subject: [movitz-cvs] CVS update: ia-x86/inline-data.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv18328 Modified Files: inline-data.lisp Log Message: Designate the ia-x86 package with #:ia-x86 rather than "IA-X86". Also, a few very minor edits. Date: Mon Feb 9 19:03:30 2004 Author: ffjeld Index: ia-x86/inline-data.lisp diff -u ia-x86/inline-data.lisp:1.2 ia-x86/inline-data.lisp:1.3 --- ia-x86/inline-data.lisp:1.2 Fri Jan 16 06:54:14 2004 +++ ia-x86/inline-data.lisp Mon Feb 9 19:03:30 2004 @@ -1,19 +1,19 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2000, +;;;; Copyright (C) 2000, 2004, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; -;;;; Filename: ia-x86-inline-data.lisp +;;;; Filename: inline-data.lisp ;;;; Description: Objects that represents inline data in assembly listings. ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Aug 21 10:35:46 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: inline-data.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: inline-data.lisp,v 1.3 2004/02/10 00:03:30 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(in-package "IA-X86") +(in-package #:ia-x86) (defclass inline-data () ()) From ffjeld at common-lisp.net Tue Feb 10 00:03:42 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:03:42 -0500 Subject: [movitz-cvs] CVS update: ia-x86/operands.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv11585 Modified Files: operands.lisp Log Message: Designate the ia-x86 package with #:ia-x86 rather than "IA-X86". Also, a few very minor edits. Date: Mon Feb 9 19:03:42 2004 Author: ffjeld Index: ia-x86/operands.lisp diff -u ia-x86/operands.lisp:1.3 ia-x86/operands.lisp:1.4 --- ia-x86/operands.lisp:1.3 Mon Feb 9 18:46:23 2004 +++ ia-x86/operands.lisp Mon Feb 9 19:03:42 2004 @@ -9,11 +9,11 @@ ;;;; Created at: Wed Feb 16 14:02:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: operands.lisp,v 1.3 2004/02/09 23:46:23 ffjeld Exp $ +;;;; $Id: operands.lisp,v 1.4 2004/02/10 00:03:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(in-package "IA-X86") +(in-package #:ia-x86) ;;; ---------------------------------------------------------------- ;;; Operand types From ffjeld at common-lisp.net Tue Feb 10 00:03:47 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:03:47 -0500 Subject: [movitz-cvs] CVS update: ia-x86/packages.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv23425 Modified Files: packages.lisp Log Message: Designate the ia-x86 package with #:ia-x86 rather than "IA-X86". Also, a few very minor edits. Date: Mon Feb 9 19:03:47 2004 Author: ffjeld Index: ia-x86/packages.lisp diff -u ia-x86/packages.lisp:1.2 ia-x86/packages.lisp:1.3 --- ia-x86/packages.lisp:1.2 Fri Jan 16 06:54:14 2004 +++ ia-x86/packages.lisp Mon Feb 9 19:03:47 2004 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 20012000, 2002-2003, +;;;; Copyright (C) 20012000, 2002-2004, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: packages.lisp @@ -9,14 +9,14 @@ ;;;; Created at: Wed Feb 16 14:02:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: packages.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: packages.lisp,v 1.3 2004/02/10 00:03:47 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(in-package "CL-USER") +(in-package #:cl-user) -(defpackage "IA-X86" - (:use "COMMON-LISP") +(defpackage #:ia-x86 + (:use #:common-lisp) (:export #:init-instruction-tables #:*cpu-mode* @@ -91,9 +91,9 @@ #:symtab-try-lookup-label )) -(defpackage "IA-X86-INSTR" - (:use "IA-X86") - (:import-from "COMMON-LISP" t nil defclass load eval compile) +(defpackage #:ia-x86-instr + (:use #:ia-x86) + (:import-from #:common-lisp t nil defclass load eval compile) (:documentation - "All the specialized classes for IA-X86 instructions are put into + "All the specialized classes for ia-x86 instructions are put into this package, so that we may have instructions named 'and' etc.")) From ffjeld at common-lisp.net Tue Feb 10 00:03:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:03:52 -0500 Subject: [movitz-cvs] CVS update: ia-x86/postload.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv513 Modified Files: postload.lisp Log Message: Designate the ia-x86 package with #:ia-x86 rather than "IA-X86". Also, a few very minor edits. Date: Mon Feb 9 19:03:52 2004 Author: ffjeld Index: ia-x86/postload.lisp diff -u ia-x86/postload.lisp:1.3 ia-x86/postload.lisp:1.4 --- ia-x86/postload.lisp:1.3 Fri Jan 16 06:54:14 2004 +++ ia-x86/postload.lisp Mon Feb 9 19:03:52 2004 @@ -9,11 +9,11 @@ ;;;; Created at: Mon Jan 31 16:33:23 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: postload.lisp,v 1.3 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: postload.lisp,v 1.4 2004/02/10 00:03:52 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(in-package "IA-X86") +(in-package #:ia-x86) (defun table-stats (prefix table) (format t "~&;; ~A ~D x86 instruction templates loaded.~%" @@ -45,12 +45,3 @@ (dotimes (i #x100 (nreverse r)) (when (null (aref table i)) (push i r))))))) - -;;;(table-stats "IA-X86: " *template-table*) -;;;(table-stats "IA-X86 2op: " *template-table-0f*) - - - - - - From ffjeld at common-lisp.net Tue Feb 10 00:03:56 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:03:56 -0500 Subject: [movitz-cvs] CVS update: ia-x86/prefixes.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv10144 Modified Files: prefixes.lisp Log Message: Designate the ia-x86 package with #:ia-x86 rather than "IA-X86". Also, a few very minor edits. Date: Mon Feb 9 19:03:56 2004 Author: ffjeld Index: ia-x86/prefixes.lisp diff -u ia-x86/prefixes.lisp:1.2 ia-x86/prefixes.lisp:1.3 --- ia-x86/prefixes.lisp:1.2 Fri Jan 16 06:54:14 2004 +++ ia-x86/prefixes.lisp Mon Feb 9 19:03:56 2004 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 20012000, 2003, +;;;; Copyright (C) 20012000, 2003-2004, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; ;;;; Filename: prefixes.lisp @@ -9,11 +9,11 @@ ;;;; Created at: Tue Aug 15 22:34:30 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: prefixes.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: prefixes.lisp,v 1.3 2004/02/10 00:03:56 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(in-package "IA-X86") +(in-package #:ia-x86) ;;; ---------------------------------------------------------------- ;;; Instruction prefixes From ffjeld at common-lisp.net Tue Feb 10 00:04:04 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:04:04 -0500 Subject: [movitz-cvs] CVS update: ia-x86/proglist.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv21377 Modified Files: proglist.lisp Log Message: Designate the ia-x86 package with #:ia-x86 rather than "IA-X86". Also, a few very minor edits. Date: Mon Feb 9 19:04:04 2004 Author: ffjeld Index: ia-x86/proglist.lisp diff -u ia-x86/proglist.lisp:1.2 ia-x86/proglist.lisp:1.3 --- ia-x86/proglist.lisp:1.2 Fri Jan 16 06:54:14 2004 +++ ia-x86/proglist.lisp Mon Feb 9 19:04:04 2004 @@ -9,11 +9,11 @@ ;;;; Created at: Mon May 15 13:43:55 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: proglist.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: proglist.lisp,v 1.3 2004/02/10 00:04:04 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(in-package "IA-X86") +(in-package #:ia-x86) (defvar *label-counter* 0) (defun make-label () From ffjeld at common-lisp.net Tue Feb 10 00:04:08 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:04:08 -0500 Subject: [movitz-cvs] CVS update: ia-x86/read.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv12096 Modified Files: read.lisp Log Message: Designate the ia-x86 package with #:ia-x86 rather than "IA-X86". Also, a few very minor edits. Date: Mon Feb 9 19:04:08 2004 Author: ffjeld Index: ia-x86/read.lisp diff -u ia-x86/read.lisp:1.2 ia-x86/read.lisp:1.3 --- ia-x86/read.lisp:1.2 Fri Jan 16 06:54:14 2004 +++ ia-x86/read.lisp Mon Feb 9 19:04:08 2004 @@ -9,11 +9,11 @@ ;;;; Created at: Mon Jul 31 13:54:27 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: read.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: read.lisp,v 1.3 2004/02/10 00:04:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(in-package "IA-X86") +(in-package #:ia-x86) ;;; Implements the following assembly syntax: ;;; @@ -63,7 +63,7 @@ (assert (member spec +all-registers+) (spec) "Expected a register: ~A" spec) - (find-symbol (symbol-name spec) "IA-X86")) + (find-symbol (symbol-name spec) #:ia-x86)) (defun is-register-p (spec) (and (symbolp spec) @@ -209,7 +209,7 @@ (loop for p in prefix-spec with user-size = nil if (symbolp p) - collect (let ((ps (find-symbol (symbol-name p) "IA-X86"))) + collect (let ((ps (find-symbol (symbol-name p) #:ia-x86))) (if (decode-set +prefix-opcode-map+ ps :errorp nil) ps (error "No such prefix: ~A" p))) @@ -218,14 +218,6 @@ do (setf user-size p) finally (return (values prefixes user-size)))) -;;; (mapcar #'(lambda (p) -;;; (let ((ps (find-symbol (symbol-name p) -;;; "IA-X86"))) -;;; (if (decode-set *prefix-opcode-map* ps :errorp nil) -;;; ps -;;; (error "No such prefix: ~A" p)))) -;;; prefix-spec)) - (defvar *find-instruction-cache* (make-hash-table :test #'eq)) (defun read-instruction (sexpr) @@ -235,10 +227,10 @@ (setf (values prefix-list user-size) (read-prefixes (first sexpr)) instr-name (second sexpr) operand-list (nthcdr 2 sexpr)) - (setf prefix-list nil - user-size nil - instr-name (first sexpr) - operand-list (nthcdr 1 sexpr))) + (setf prefix-list nil + user-size nil + instr-name (first sexpr) + operand-list (nthcdr 1 sexpr))) (case instr-name (:align (make-instance 'alignment :type operand-list)) @@ -246,14 +238,14 @@ (mapcar #'read-operand operand-list)) (t (make-instance (or (gethash instr-name *find-instruction-cache*) (setf (gethash instr-name *find-instruction-cache*) - (multiple-value-bind (instr-symbol instr-symbol-status) - (find-symbol (string instr-name) "IA-X86-INSTR") - (unless instr-symbol-status - (error "No instruction named ~A." (string instr-name))) - instr-symbol))) - 'prefixes prefix-list - 'user-size user-size - 'operands (mapcar #'read-operand operand-list)))))) + (multiple-value-bind (instr-symbol instr-symbol-status) + (find-symbol (string instr-name) #:ia-x86-instr) + (unless instr-symbol-status + (error "No instruction named ~A." (string instr-name))) + instr-symbol))) + 'prefixes prefix-list + 'user-size user-size + 'operands (mapcar #'read-operand operand-list)))))) (defun inline-data-p (expr) From ffjeld at common-lisp.net Tue Feb 10 00:04:13 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:04:13 -0500 Subject: [movitz-cvs] CVS update: ia-x86/registers.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv23107 Modified Files: registers.lisp Log Message: Designate the ia-x86 package with #:ia-x86 rather than "IA-X86". Also, a few very minor edits. Date: Mon Feb 9 19:04:13 2004 Author: ffjeld Index: ia-x86/registers.lisp diff -u ia-x86/registers.lisp:1.2 ia-x86/registers.lisp:1.3 --- ia-x86/registers.lisp:1.2 Fri Jan 16 06:54:14 2004 +++ ia-x86/registers.lisp Mon Feb 9 19:04:13 2004 @@ -1,19 +1,19 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2000, +;;;; Copyright (C) 2000, 2004, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; -;;;; Filename: ia-x86-registers.lisp +;;;; Filename: registers.lisp ;;;; Description: ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Aug 1 10:24:59 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: registers.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: registers.lisp,v 1.3 2004/02/10 00:04:13 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(in-package "IA-X86") +(in-package #:ia-x86) ;;; ---------------------------------------------------------------- ;;; Register sets From ffjeld at common-lisp.net Tue Feb 10 00:04:19 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:04:19 -0500 Subject: [movitz-cvs] CVS update: ia-x86/symtab.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv31617 Modified Files: symtab.lisp Log Message: Designate the ia-x86 package with #:ia-x86 rather than "IA-X86". Also, a few very minor edits. Date: Mon Feb 9 19:04:19 2004 Author: ffjeld Index: ia-x86/symtab.lisp diff -u ia-x86/symtab.lisp:1.2 ia-x86/symtab.lisp:1.3 --- ia-x86/symtab.lisp:1.2 Fri Jan 16 06:54:14 2004 +++ ia-x86/symtab.lisp Mon Feb 9 19:04:19 2004 @@ -1,19 +1,19 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 2000, +;;;; Copyright (C) 2000, 2004, ;;;; Department of Computer Science, University of Tromso, Norway ;;;; -;;;; Filename: ia-x86-symtab.lisp +;;;; Filename: symtab.lisp ;;;; Description: Assembly symbolic lookups. ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Tue Aug 22 10:01:38 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: symtab.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: symtab.lisp,v 1.3 2004/02/10 00:04:19 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ -(in-package "IA-X86") +(in-package #:ia-x86) ;;; A symtab is a stack-organized list of "frames", where each frame ;;; is a hash-table. From ffjeld at common-lisp.net Tue Feb 10 00:04:24 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:04:24 -0500 Subject: [movitz-cvs] CVS update: ia-x86/utilities.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv9504 Modified Files: utilities.lisp Log Message: Designate the ia-x86 package with #:ia-x86 rather than "IA-X86". Also, a few very minor edits. Date: Mon Feb 9 19:04:24 2004 Author: ffjeld Index: ia-x86/utilities.lisp diff -u ia-x86/utilities.lisp:1.2 ia-x86/utilities.lisp:1.3 --- ia-x86/utilities.lisp:1.2 Fri Jan 16 06:54:14 2004 +++ ia-x86/utilities.lisp Mon Feb 9 19:04:24 2004 @@ -1,6 +1,6 @@ ;;;;------------------------------------------------------------------ ;;;; -;;;; Copyright (C) 20012000, 2003, Frode Vatved Fjeld +;;;; Copyright (C) 20012000, 2003-2004, Frode Vatved Fjeld ;;;; ;;;; Filename: utilities.lisp ;;;; Description: @@ -8,13 +8,13 @@ ;;;; Created at: Sun Nov 2 14:51:21 EET 2003 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: utilities.lisp,v 1.2 2004/01/16 11:54:14 ffjeld Exp $ +;;;; $Id: utilities.lisp,v 1.3 2004/02/10 00:04:24 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ ;; FIXME: There is probably a better place in the great scheme of ;; things for stuff like this... -(in-package "IA-X86") +(in-package #:ia-x86) ;; Unfortunately ANSI doesn't specify the slots and initargs of ;; STYLE-WARNINGS... but we don't want to signal full WARNIGN either, From ffjeld at common-lisp.net Tue Feb 10 00:13:29 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:13:29 -0500 Subject: [movitz-cvs] CVS update: ia-x86/read.lisp Message-ID: Update of /project/movitz/cvsroot/ia-x86 In directory common-lisp.net:/tmp/cvs-serv6595 Modified Files: read.lisp Log Message: Forgot to quote #:ia-x86 when appearing as forms. Repeat after me: Don't check in code that has not been tested. Don't check in code that has not been tested. Date: Mon Feb 9 19:13:29 2004 Author: ffjeld Index: ia-x86/read.lisp diff -u ia-x86/read.lisp:1.3 ia-x86/read.lisp:1.4 --- ia-x86/read.lisp:1.3 Mon Feb 9 19:04:08 2004 +++ ia-x86/read.lisp Mon Feb 9 19:13:29 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.3 2004/02/10 00:04:08 ffjeld Exp $ +;;;; $Id: read.lisp,v 1.4 2004/02/10 00:13:29 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -63,7 +63,7 @@ (assert (member spec +all-registers+) (spec) "Expected a register: ~A" spec) - (find-symbol (symbol-name spec) #:ia-x86)) + (find-symbol (symbol-name spec) '#:ia-x86)) (defun is-register-p (spec) (and (symbolp spec) @@ -209,7 +209,7 @@ (loop for p in prefix-spec with user-size = nil if (symbolp p) - collect (let ((ps (find-symbol (symbol-name p) #:ia-x86))) + collect (let ((ps (find-symbol (symbol-name p) '#:ia-x86))) (if (decode-set +prefix-opcode-map+ ps :errorp nil) ps (error "No such prefix: ~A" p))) @@ -239,7 +239,7 @@ (t (make-instance (or (gethash instr-name *find-instruction-cache*) (setf (gethash instr-name *find-instruction-cache*) (multiple-value-bind (instr-symbol instr-symbol-status) - (find-symbol (string instr-name) #:ia-x86-instr) + (find-symbol (string instr-name) '#:ia-x86-instr) (unless instr-symbol-status (error "No instruction named ~A." (string instr-name))) instr-symbol))) From ffjeld at common-lisp.net Tue Feb 10 00:23:40 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:23:40 -0500 Subject: [movitz-cvs] CVS update: movitz/stream-image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv16321 Modified Files: stream-image.lisp Log Message: Added a fall-back method image-register32 for stream-images. Date: Mon Feb 9 19:23:40 2004 Author: ffjeld Index: movitz/stream-image.lisp diff -u movitz/stream-image.lisp:1.2 movitz/stream-image.lisp:1.3 --- movitz/stream-image.lisp:1.2 Mon Jan 19 06:23:41 2004 +++ movitz/stream-image.lisp Mon Feb 9 19:23:39 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Mon Aug 27 14:46:50 2001 ;;;; -;;;; $Id: stream-image.lisp,v 1.2 2004/01/19 11:23:41 ffjeld Exp $ +;;;; $Id: stream-image.lisp,v 1.3 2004/02/10 00:23:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -33,6 +33,10 @@ :initarg :nil-word :initform #x65 :reader image-nil-word))) + +(defmethod image-register32 ((image stream-image) register-name) + (declare (ignorable image) (ignore register-name)) + (error "A stream-image has no CPU state.")) (defmethod (setf image-stream-position) (value (image stream-image) &optional physicalp) (check-type value (integer 0 *)) From ffjeld at common-lisp.net Tue Feb 10 00:24:38 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:24:38 -0500 Subject: [movitz-cvs] CVS update: movitz/environment.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv2698 Modified Files: environment.lisp Log Message: Misspelled movitz-funobj-name as funobj-name. Date: Mon Feb 9 19:24:38 2004 Author: ffjeld Index: movitz/environment.lisp diff -u movitz/environment.lisp:1.3 movitz/environment.lisp:1.4 --- movitz/environment.lisp:1.3 Thu Feb 5 09:46:08 2004 +++ movitz/environment.lisp Mon Feb 9 19:24:38 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.3 2004/02/05 14:46:08 ffjeld Exp $ +;;;; $Id: environment.lisp,v 1.4 2004/02/10 00:24:38 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -198,7 +198,7 @@ (call-next-method)) (t (print-unreadable-object (object stream :type t :identity t) (format stream "of ~A binding~?" - (funobj-name (movitz-environment-funobj object)) + (movitz-funobj-name (movitz-environment-funobj object)) "~#[ nothing~; ~S~; ~S and ~S~:;~@{~#[~; and~] ~S~^,~}~]" (mapcar #'binding-name (mapcar #'cdr (movitz-environment-bindings object))))) object))) From ffjeld at common-lisp.net Tue Feb 10 00:25:28 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:25:28 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5981 Modified Files: compiler.lisp Log Message: Moved defconstant +enter-stack-frame-code+ to top of file. Date: Mon Feb 9 19:25:28 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.18 movitz/compiler.lisp:1.19 --- movitz/compiler.lisp:1.18 Sun Feb 8 18:24:13 2004 +++ movitz/compiler.lisp Mon Feb 9 19:25:28 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.18 2004/02/08 23:24:13 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.19 2004/02/10 00:25:28 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -54,6 +54,11 @@ (defvar *compiling-function-name*) (defvar muerte.cl:*compile-file-pathname* nil) +(defconstant +enter-stack-frame-code+ + '((:pushl :ebp) + (:movl :esp :ebp) + (:pushl :esi))) + (defun duplicatesp (list) "Returns TRUE iff at least one object occurs more than once in LIST." (if (null list) @@ -874,11 +879,6 @@ (values '((:pushl :ebx)) 1)) (t (error "make-2req confused by loc0: ~W, loc1: ~W" location-0 location-1))))) - -(defconstant +enter-stack-frame-code+ - '((:pushl :ebp) - (:movl :esp :ebp) - (:pushl :esi))) #+ignore (defun make-compiled-function-body-1rest (form funobj env top-level-p) From ffjeld at common-lisp.net Tue Feb 10 00:28:34 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:28:34 -0500 Subject: [movitz-cvs] CVS update: movitz/compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv5064 Modified Files: compiler.lisp Log Message: Removed defconstant +code-vector-entry-factor+ which I don't really know what was for. Date: Mon Feb 9 19:28:34 2004 Author: ffjeld Index: movitz/compiler.lisp diff -u movitz/compiler.lisp:1.19 movitz/compiler.lisp:1.20 --- movitz/compiler.lisp:1.19 Mon Feb 9 19:25:28 2004 +++ movitz/compiler.lisp Mon Feb 9 19:28:34 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.19 2004/02/10 00:25:28 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.20 2004/02/10 00:28:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -110,8 +110,6 @@ (warn "~S shrunk from ~D to ~D bytes" name old-size new-size)))) (setf (gethash hash-name (function-code-sizes *image*)) new-size)) funobj) - -(defconstant +code-vector-entry-factor+ 1) (defclass movitz-funobj-pass1 () ((name From ffjeld at common-lisp.net Tue Feb 10 00:29:10 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:29:10 -0500 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv29570 Modified Files: image.lisp Log Message: Don't use +code-vector-entry-factor+. Date: Mon Feb 9 19:29:10 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.10 movitz/image.lisp:1.11 --- movitz/image.lisp:1.10 Mon Feb 9 18:41:13 2004 +++ movitz/image.lisp Mon Feb 9 19:29:10 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.10 2004/02/09 23:41:13 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.11 2004/02/10 00:29:10 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1192,7 +1192,7 @@ collect (list pc nil (format nil " => Entry-point for ~D arguments <=" (1+ (position-if (lambda (x) - (= pc (* x +code-vector-entry-factor+))) + (= pc x)) entry-points))) nil) collect (list pc From ffjeld at common-lisp.net Tue Feb 10 00:32:09 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:32:09 -0500 Subject: [movitz-cvs] CVS update: movitz/image.lisp Message-ID: Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv30608 Modified Files: image.lisp Log Message: Really don't use +code-vector-entry-factor+. Date: Mon Feb 9 19:32:09 2004 Author: ffjeld Index: movitz/image.lisp diff -u movitz/image.lisp:1.11 movitz/image.lisp:1.12 --- movitz/image.lisp:1.11 Mon Feb 9 19:29:10 2004 +++ movitz/image.lisp Mon Feb 9 19:32:08 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.11 2004/02/10 00:29:10 ffjeld Exp $ +;;;; $Id: image.lisp,v 1.12 2004/02/10 00:32:08 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1187,7 +1187,7 @@ (when x (list pc (list (format nil " ~S" (car x))) "" nil))) collect it when (some (lambda (x) - (and (plusp pc) (= pc (* x +code-vector-entry-factor+)))) + (and (plusp pc) (= pc x))) entry-points) collect (list pc nil (format nil " => Entry-point for ~D arguments <=" From ffjeld at common-lisp.net Tue Feb 10 00:38:46 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:38:46 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv24768 Modified Files: los-closette-compiler.lisp Log Message: Added some ignore declarations to get rid of some warnings. Date: Mon Feb 9 19:38:45 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.4 movitz/losp/muerte/los-closette-compiler.lisp:1.5 --- movitz/losp/muerte/los-closette-compiler.lisp:1.4 Wed Feb 4 10:29:25 2004 +++ movitz/losp/muerte/los-closette-compiler.lisp Mon Feb 9 19:38:45 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.4 2004/02/04 15:29:25 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.5 2004/02/10 00:38:45 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -589,7 +589,7 @@ ;;; (defun movitz-make-instance-funcallable (metaclass &rest all-keys &key name direct-superclasses direct-slots &allow-other-keys) - ;; (declare (ignore metaclass)) + (declare (ignore all-keys)) (let ((class (std-allocate-instance metaclass))) #+ignore (dolist (slot (class-slots (movitz-class-of class))) @@ -650,7 +650,7 @@ &key name slots direct-slots ((:metaclass dummy)) (direct-superclasses (list (movitz-find-class 'structure-object)))) - (declare (ignore dummy)) + (declare (ignore dummy all-keys)) (assert (null direct-slots)) (let ((class (std-allocate-instance (if (symbolp metaclass) (movitz-find-class metaclass) From ffjeld at common-lisp.net Tue Feb 10 00:39:52 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:39:52 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv23043 Modified Files: los-closette-compiler.lisp Log Message: Added placeholder defun compute-class-precedence-list. Date: Mon Feb 9 19:39:52 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.5 movitz/losp/muerte/los-closette-compiler.lisp:1.6 --- movitz/losp/muerte/los-closette-compiler.lisp:1.5 Mon Feb 9 19:38:45 2004 +++ movitz/losp/muerte/los-closette-compiler.lisp Mon Feb 9 19:39:51 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.5 2004/02/10 00:38:45 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.6 2004/02/10 00:39:51 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -745,6 +745,10 @@ classes-to-order) :test #'equal) #'std-tie-breaker-rule))) + + (defun compute-class-precedence-list (class) + (error "Don't know how to compute class-precedence-list for ~S of class ~S." + class (class-of class))) ;;; topological-sort implements the standard algorithm for topologically ;;; sorting an arbitrary set of elements while honoring the precedence From ffjeld at common-lisp.net Tue Feb 10 00:41:42 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:41:42 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11795 Modified Files: los-closette-compiler.lisp Log Message: Added placeholder defun compute-effective-slot-definition. Date: Mon Feb 9 19:41:42 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.6 movitz/losp/muerte/los-closette-compiler.lisp:1.7 --- movitz/losp/muerte/los-closette-compiler.lisp:1.6 Mon Feb 9 19:39:51 2004 +++ movitz/losp/muerte/los-closette-compiler.lisp Mon Feb 9 19:41:42 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.6 2004/02/10 00:39:51 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.7 2004/02/10 00:41:42 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -865,6 +865,10 @@ direct-slots)) :allocation (slot-definition-allocation (car direct-slots))))) + (defun compute-effective-slot-definition (class name direct-slots) + (declare (ignore name direct-slots)) + (error "Don't know how to compute-effective-slot-definition for class ~S of class ~S." + class (class-of class))) ;;;; From ffjeld at common-lisp.net Tue Feb 10 00:42:37 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:42:37 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv32704 Modified Files: los-closette-compiler.lisp Log Message: Added place-holder defun compute-slots. Date: Mon Feb 9 19:42:37 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.7 movitz/losp/muerte/los-closette-compiler.lisp:1.8 --- movitz/losp/muerte/los-closette-compiler.lisp:1.7 Mon Feb 9 19:41:42 2004 +++ movitz/losp/muerte/los-closette-compiler.lisp Mon Feb 9 19:42:37 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.7 2004/02/10 00:41:42 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.8 2004/02/10 00:42:37 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -847,6 +847,10 @@ (loop for i upfrom 0 as slot in effective-slots do (setf (slot-definition-location slot) i)) effective-slots)) + + (defun compute-slots (class) + (error "Don't know how to compute-slots for class ~S of class ~S." + class (class-of class))) (defun std-compute-effective-slot-definition (class name direct-slots) (declare (ignore name)) From ffjeld at common-lisp.net Tue Feb 10 00:43:43 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 19:43:43 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv3770 Modified Files: los-closette-compiler.lisp Log Message: Added place-holder defun finalize-inheritance. Date: Mon Feb 9 19:43:43 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.8 movitz/losp/muerte/los-closette-compiler.lisp:1.9 --- movitz/losp/muerte/los-closette-compiler.lisp:1.8 Mon Feb 9 19:42:37 2004 +++ movitz/losp/muerte/los-closette-compiler.lisp Mon Feb 9 19:43:43 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.8 2004/02/10 00:42:37 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.9 2004/02/10 00:43:43 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -732,6 +732,10 @@ #'compute-slots) class)) (values)) + + (defun finalize-inheritance (class) + (error "Don't know how to finalize-inheritance for class ~S of class ~S." + class (class-of class))) ;;; Class precedence lists From ffjeld at common-lisp.net Tue Feb 10 01:03:42 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Mon, 09 Feb 2004 20:03:42 -0500 Subject: [movitz-cvs] CVS update: movitz/losp/muerte/los-closette-compiler.lisp Message-ID: Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv11612 Modified Files: los-closette-compiler.lisp Log Message: Avoid warning about undeclared variable *the-standard-method-combination*. Date: Mon Feb 9 20:03:41 2004 Author: ffjeld Index: movitz/losp/muerte/los-closette-compiler.lisp diff -u movitz/losp/muerte/los-closette-compiler.lisp:1.9 movitz/losp/muerte/los-closette-compiler.lisp:1.10 --- movitz/losp/muerte/los-closette-compiler.lisp:1.9 Mon Feb 9 19:43:43 2004 +++ movitz/losp/muerte/los-closette-compiler.lisp Mon Feb 9 20:03:41 2004 @@ -10,7 +10,7 @@ ;;;; Author: Frode Vatvedt Fjeld ;;;; Created at: Thu Aug 29 13:15:11 2002 ;;;; -;;;; $Id: los-closette-compiler.lisp,v 1.9 2004/02/10 00:43:43 ffjeld Exp $ +;;;; $Id: los-closette-compiler.lisp,v 1.10 2004/02/10 01:03:41 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------ @@ -1111,7 +1111,7 @@ (generic-function-lambda-list gf) lambda-list (generic-function-methods gf) () (generic-function-method-class gf) method-class - (generic-function-method-combination gf) *the-standard-method-combination*) + (generic-function-method-combination gf) (symbol-value '*the-standard-method-combination*)) (finalize-generic-function gf) gf)) From ffjeld at common-lisp.net Tue Feb 10 11:39:31 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 10 Feb 2004 06:39:31 -0500 Subject: [movitz-cvs] CVS update: public_html/index.html Message-ID: Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv30112 Modified Files: index.html Log Message: Updated/added some general info about Movitz building. Date: Tue Feb 10 06:39:31 2004 Author: ffjeld Index: public_html/index.html diff -u public_html/index.html:1.11 public_html/index.html:1.12 --- public_html/index.html:1.11 Wed Jan 14 11:48:01 2004 +++ public_html/index.html Tue Feb 10 06:39:31 2004 @@ -16,12 +16,12 @@

Introduction

The Movitz system aspires to be an implementation of ANSI Common -Lisp that targets the ubiquitous x86 PC architecture "on the -metal". That is, running without any operating system or other form of -software environment. Movitz is a development platform for operating -system kernels, embedded, and single-purpose applications. There can -potentially be several completely different operating systems built -using Movitz.

+ Lisp that targets the ubiquitous x86 PC architecture "on the + metal". That is, running without any operating system or other form + of software environment. Movitz is a development platform for + operating system kernels, embedded, and single-purpose + applications. There can potentially be several completely different + operating systems built using Movitz.

More information about Movitz concepts. @@ -63,17 +63,21 @@

  • movitz
  • -

    The former two are required for building and using the latter. - Also, both ia-x86 and binary-types have been somewhat tested for - portability, whereas Movitz itself has only ever been used with - Allegro CL. I'm hoping that someone with experience with other lisp - implementations than Allegro can make movitz runnable under their - system, and submit patches to that effect to - movitz-devel at common-lisp.net. - +

    The former two are required for building and using the + latter. So far, this combo has been run under Allegro, SBCL, and + CMUCL, but everything is supposed to be platform-independent ANSI + Common Lisp. CLisp apparently dumps core for some reason during the + build process.

    + + The main build process is run by two operators. Create-image creates + a symbolic Movitz lisp-world from scratch. This symbolic + representation is loaded into the variable
    *image*
    , which + holds "the current image" for many Movitz operators. The function + dump-image transforms a symbolic image to a bootable image file. From ffjeld at common-lisp.net Tue Feb 10 11:42:30 2004 From: ffjeld at common-lisp.net (Frode Vatvedt Fjeld) Date: Tue, 10 Feb 2004 06:42:30 -0500 Subject: [movitz-cvs] CVS update: public_html/index.html Message-ID: Update of /project/movitz/cvsroot/public_html In directory common-lisp.net:/tmp/cvs-serv8732 Modified Files: index.html Log Message: html tinkering Date: Tue Feb 10 06:42:30 2004 Author: ffjeld Index: public_html/index.html diff -u public_html/index.html:1.12 public_html/index.html:1.13 --- public_html/index.html:1.12 Tue Feb 10 06:39:31 2004 +++ public_html/index.html Tue Feb 10 06:42:30 2004 @@ -71,9 +71,11 @@ The main build process is run by two operators. Create-image creates a symbolic Movitz lisp-world from scratch. This symbolic - representation is loaded into the variable
    *image*
    , which + representation is loaded into the variable *image*, which holds "the current image" for many Movitz operators. The function - dump-image transforms a symbolic image to a bootable image file. + dump-image transforms a symbolic image to a bootable image file.

    + +