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.