[movitz-cvs] CVS movitz
ffjeld
ffjeld at common-lisp.net
Mon Feb 26 21:18:37 UTC 2007
Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv28550
Modified Files:
compiler.lisp
Log Message:
Refactor movitz-compile-file & friends, primarily in order to expose
new function movitz-compile-stream.
--- /project/movitz/cvsroot/movitz/compiler.lisp 2007/02/22 21:00:21 1.178
+++ /project/movitz/cvsroot/movitz/compiler.lisp 2007/02/26 21:18:37 1.179
@@ -8,7 +8,7 @@
;;;; Created at: Wed Oct 25 12:30:49 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: compiler.lisp,v 1.178 2007/02/22 21:00:21 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.179 2007/02/26 21:18:37 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -1223,252 +1223,99 @@
1))
(t (error "make-2req confused by loc0: ~W, loc1: ~W" location-0 location-1)))))
-;;;(defun make-compiled-function-body-1rest (form funobj env top-level-p)
-;;; (when (and (null (required-vars env))
-;;; (null (optional-vars env))
-;;; (null (key-vars env))
-;;; (rest-var env))
-;;; (multiple-value-bind (code stack-frame-size use-stack-frame-p frame-map)
-;;; (make-compiled-body form funobj env top-level-p)
-;;; (let* ((rest-binding (movitz-binding (rest-var env) env nil))
-;;; (edx-location (and (edx-var env)
-;;; (new-binding-location (edx-var env) frame-map
-;;; :default nil)))
-;;; (edx-code (when edx-location
-;;; `((:movl :edx (:ebp ,(stack-frame-offset edx-location)))))))
-;;; (cond
-;;; ((not (new-binding-located-p rest-binding frame-map))
-;;; (append '(entry%1op
-;;; entry%2op
-;;; entry%3op)
-;;; (when use-stack-frame-p
-;;; +enter-stack-frame-code+)
-;;; '(start-stack-frame-setup)
-;;; (make-compiled-stack-frame-init stack-frame-size)
-;;; edx-code
-;;; code
-;;; (make-compiled-function-postlude funobj env use-stack-frame-p)))
-;;; (t ;; (new-binding-located-p rest-binding frame-map)
-;;; (let ((rest-location (new-binding-location rest-binding frame-map)))
-;;; (values (append +enter-stack-frame-code+
-;;; '(start-stack-frame-setup)
-;;; (make-compiled-stack-frame-init stack-frame-size)
-;;; `((:movl :edi (:ebp ,(stack-frame-offset rest-location))))
-;;; edx-code
-;;; `((:testb :cl :cl)
-;;; (:jz 'end-stack-frame-setup)
-;;; (:js '(:sub-program (normalize-ecx)
-;;; (:shrl 8 :ecx)
-;;; (:jmp 'ecx-ok)))
-;;; (:andl #x7f :ecx)
-;;; ecx-ok
-;;; (:xorl :edx :edx)
-;;; (:call (:edi ,(global-constant-offset 'restify-dynamic-extent)))
-;;; (:movl :eax (:ebp ,(stack-frame-offset rest-location)))
-;;; (:jmp 'end-stack-frame-setup))
-;;; `(entry%1op
-;;; , at +enter-stack-frame-code+
-;;; ,@(make-compiled-stack-frame-init stack-frame-size)
-;;; , at edx-code
-;;; (:andl -8 :esp)
-;;; (:pushl :edi)
-;;; (:pushl :eax)
-;;; (:leal (:esp 1) :ecx)
-;;; (:movl :ecx (:ebp ,(stack-frame-offset rest-location)))
-;;; (:jmp 'end-stack-frame-setup))
-;;; `(entry%2op
-;;; , at +enter-stack-frame-code+
-;;; ,@(make-compiled-stack-frame-init stack-frame-size)
-;;; , at edx-code
-;;; (:andl -8 :esp)
-;;; (:pushl :edi)
-;;; (:pushl :ebx)
-;;; (:leal (:esp 1) :ecx)
-;;; (:pushl :ecx)
-;;; (:pushl :eax)
-;;; (:leal (:esp 1) :ecx)
-;;; (:movl :ecx (:ebp ,(stack-frame-offset rest-location)))
-;;; (:jmp 'end-stack-frame-setup))
-;;; '(end-stack-frame-setup)
-;;; code
-;;; (make-compiled-function-postlude funobj env t))
-;;; use-stack-frame-p))))))))
-
-;;;(defun make-compiled-function-body-1req-1opt (form funobj env top-level-p)
-;;; (when (and (= 1 (length (required-vars env)))
-;;; (= 1 (length (optional-vars env)))
-;;; (= 0 (length (key-vars env)))
-;;; (null (rest-var env)))
-;;; (let* ((opt-var (first (optional-vars env)))
-;;; (opt-binding (movitz-binding opt-var env nil))
-;;; (req-binding (movitz-binding (first (required-vars env)) env nil))
-;;; (default-form (optional-function-argument-init-form opt-binding)))
-;;; (compiler-values-bind (&code opt-default-code &producer opt-default-producer)
-;;; (compiler-call #'compile-form
-;;; :form default-form
-;;; :result-mode :push
-;;; :env env
-;;; :funobj funobj)
-;;; (cond
-;;; ((eq 'compile-self-evaluating opt-default-producer)
-;;; (multiple-value-bind (code stack-frame-size use-stack-frame-p frame-map)
-;;; (make-compiled-body form funobj env top-level-p nil (list opt-default-code))
-;;; (declare (ignore use-stack-frame-p))
-;;; (let ((use-stack-frame-p t))
-;;; (cond
-;;; ((and (new-binding-located-p req-binding frame-map)
-;;; (new-binding-located-p opt-binding frame-map))
-;;; (multiple-value-bind (eax-ebx-code eax-ebx-stack-offset)
-;;; (ecase (new-binding-location req-binding frame-map)
-;;; ;; might well be more cases here, but let's wait till they show up..
-;;; (:eax (values nil 0))
-;;; (1 (values '((:pushl :eax)) 1)))
-;;; ;; (warn "defc: ~S" opt-default-code)
-;;; (let ((stack-init-size (- stack-frame-size eax-ebx-stack-offset))
-;;; (installed-default-code (finalize-code opt-default-code funobj env frame-map)))
-;;; (values (append `((:call (:edi ,(global-constant-offset 'decode-args-1or2)))
-;;; entry%2op
-;;; (:pushl :ebp)
-;;; (:movl :esp :ebp)
-;;; (:pushl :esi)
-;;; start-stack-frame-setup
-;;; , at eax-ebx-code
-;;; ,@(if (eql (1+ eax-ebx-stack-offset)
-;;; (new-binding-location opt-binding frame-map))
-;;; (append `((:pushl :ebx))
-;;; (make-compiled-stack-frame-init (1- stack-init-size)))
-;;; (append (make-compiled-stack-frame-init stack-init-size)
-;;; `((:movl :ebx (:ebp ,(stack-frame-offset
-;;; (new-binding-location opt-binding
-;;; frame-map)))))))
-;;; (:jmp 'arg-init-done)
-;;; entry%1op
-;;; (:pushl :ebp)
-;;; (:movl :esp :ebp)
-;;; (:pushl :esi)
-;;; , at eax-ebx-code
-;;; ,@(if (eql (1+ eax-ebx-stack-offset)
-;;; (new-binding-location opt-binding frame-map))
-;;; (append installed-default-code
-;;; (make-compiled-stack-frame-init (1- stack-init-size)))
-;;; (append (make-compiled-stack-frame-init stack-init-size)
-;;; installed-default-code
-;;; `((:popl (:ebp ,(stack-frame-offset
-;;; (new-binding-location opt-binding
-;;; frame-map)))))))
-;;; arg-init-done)
-;;; code
-;;; (make-compiled-function-postlude funobj env t))
-;;; use-stack-frame-p))))
-;;; ((and (new-binding-located-p req-binding frame-map)
-;;; (not (new-binding-located-p opt-binding frame-map)))
-;;; (multiple-value-bind (eax-code eax-stack-offset)
-;;; (ecase (new-binding-location req-binding frame-map)
-;;; (:eax (values nil 0))
-;;; (1 (values '((:pushl :eax)) 1)))
-;;; (values (append `((:call (:edi ,(global-constant-offset 'decode-args-1or2)))
-;;; ;; (:jmp 'decode-numargs)
-;;; entry%1op
-;;; entry%2op
-;;; (:pushl :ebp)
-;;; (:movl :esp :ebp)
-;;; (:pushl :esi))
-;;; eax-code
-;;; (make-compiled-stack-frame-init (- stack-frame-size eax-stack-offset))
-;;; code
-;;; (make-compiled-function-postlude funobj env t))
-;;; use-stack-frame-p)))
-;;; (t (warn "1-req-1-opt failed"))))))
-;;; (t nil))))))
(defun movitz-compile-file (path &key ((:image *image*) *image*)
- load-priority
- (delete-file-p nil))
+ load-priority
+ (delete-file-p nil))
(handler-bind
- (#+sbcl (sb-ext:defconstant-uneql #'continue)
- #+lispworks-personal-edition
- (conditions:stack-overflow (lambda (&optional c)
- (declare (ignore c))
- (warn "Stack overflow. Skipping function ~S.~%"
- *compiling-function-name*)
- (invoke-restart 'skip-toplevel-form)))
- #+ignore ((or error warning) (lambda (c)
- (declare (ignore c))
- (format *error-output* "~&;; In file ~S:" path))))
+ (#+sbcl (sb-ext:defconstant-uneql #'continue))
(unwind-protect
- (let ((*movitz-host-features* *features*)
- (*features* (image-movitz-features *image*)))
- (multiple-value-prog1
- (movitz-compile-file-internal path load-priority)
- (unless (equalp *features* (image-movitz-features *image*))
- (warn "*features* changed from ~S to ~S." (image-movitz-features *image*) *features*)
- (setf (image-movitz-features *image*) *features*))))
+ (let ((*movitz-host-features* *features*)
+ (*features* (image-movitz-features *image*)))
+ (multiple-value-prog1
+ (movitz-compile-file-internal path load-priority)
+ (unless (equalp *features* (image-movitz-features *image*))
+ (warn "*features* changed from ~S to ~S." (image-movitz-features *image*) *features*)
+ (setf (image-movitz-features *image*) *features*))))
(when delete-file-p
(assert (equal (pathname-directory "/tmp/")
(pathname-directory path))
- (path)
- "Refusing to delete file not in /tmp.")
+ (path)
+ "Refusing to delete file not in /tmp.")
(delete-file path)))))
-(defun movitz-compile-file-internal (path
- &optional (*default-load-priority*
- (and (boundp '*default-load-priority*)
- (symbol-value '*default-load-priority*)
- (1+ (symbol-value '*default-load-priority*)))))
+(defun movitz-compile-file-internal (path &optional (*default-load-priority*
+ (and (boundp '*default-load-priority*)
+ (symbol-value '*default-load-priority*)
+ (1+ (symbol-value '*default-load-priority*)))))
(declare (special *default-load-priority*))
(with-simple-restart (continue "Skip Movitz compilation of ~S." path)
(with-retries-until-true (retry "Restart Movitz compilation of ~S." path)
- ;; (warn "Compiling ~A.." path)
- (let* ((muerte.cl::*compile-file-pathname* path)
- (*package* (find-package :muerte))
- (funobj (make-instance 'movitz-funobj-pass1
- :name (intern (format nil "~A" path) :muerte)
- :lambda-list (movitz-read nil)))
- (funobj-env (make-local-movitz-environment nil funobj
- :type 'funobj-env
- :declaration-context :funobj))
- (function-env (make-local-movitz-environment funobj-env funobj
- :type 'function-env
- :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 ()
- (read stream nil '#0=#:eof))
- until (eq form '#0#)
- appending
- (with-simple-restart (skip-toplevel-form
- "Skip the compilation of top-level form~@[ ~A~]."
- (cond
- ((symbolp form) form)
- ((symbolp (car form)) (car form))))
- (when *compiler-verbose-p*
- (format *query-io* "~&Movitz Compiling ~S..~%"
- (cond
- ((symbolp form) form)
- ((symbolp (car form))
- (xsubseq form 0 2)))))
- (compiler-call #'compile-form
- :form form
- :funobj funobj
- :env function-env
- :top-level-p t
- :result-mode :ignore)))))))
- (cond
- ((null file-code)
- (setf (image-load-time-funobjs *image*)
- (delete funobj (image-load-time-funobjs *image*) :key #'first))
- 'muerte::constantly-true)
- (t (setf (extended-code function-env) file-code
- (need-normalized-ecx-p function-env) nil
- (function-envs funobj) (list (cons 'muerte.cl::t function-env))
- (funobj-env funobj) funobj-env)
- (make-compiled-funobj-pass2 funobj)
- (let ((name (funobj-name funobj)))
- (setf (movitz-env-named-function name) funobj)
- name)))))))
+ (with-open-file (stream path :direction :input)
+ (movitz-compile-stream-internal stream :path path)))))
+
+(defun movitz-compile-stream (stream &key (path "unknown-toplevel.lisp"))
+ (handler-bind
+ (#+sbcl (sb-ext:defconstant-uneql #'continue))
+ (unwind-protect
+ (let ((*movitz-host-features* *features*)
+ (*features* (image-movitz-features *image*)))
+ (multiple-value-prog1
+ (movitz-compile-stream-internal stream :path path)
+ (unless (equalp *features* (image-movitz-features *image*))
+ (warn "*features* changed from ~S to ~S." (image-movitz-features *image*) *features*)
+ (setf (image-movitz-features *image*) *features*)))))))
+
+(defun movitz-compile-stream-internal (stream &key (path "unknown-toplevel.lisp"))
+ (let* ((muerte.cl::*compile-file-pathname* path)
+ (*package* (find-package :muerte))
+ (funobj (make-instance 'movitz-funobj-pass1
+ :name (intern (format nil "~A" path) :muerte)
+ :lambda-list (movitz-read nil)))
+ (funobj-env (make-local-movitz-environment nil funobj
+ :type 'funobj-env
+ :declaration-context :funobj))
+ (function-env (make-local-movitz-environment funobj-env funobj
+ :type 'function-env
+ :declaration-context :funobj))
+ (file-code
+ (with-compilation-unit ()
+ (add-bindings-from-lambda-list () function-env)
+ (setf (funobj-env funobj) funobj-env)
+ (loop for form = (with-movitz-syntax ()
+ (read stream nil '#0=#:eof))
+ until (eq form '#0#)
+ appending
+ (with-simple-restart (skip-toplevel-form
+ "Skip the compilation of top-level form~@[ ~A~]."
+ (cond
+ ((symbolp form) form)
+ ((symbolp (car form)) (car form))))
+ (when *compiler-verbose-p*
+ (format *query-io* "~&Movitz Compiling ~S..~%"
+ (cond
+ ((symbolp form) form)
+ ((symbolp (car form))
+ (xsubseq form 0 2)))))
+ (compiler-call #'compile-form
+ :form form
+ :funobj funobj
+ :env function-env
+ :top-level-p t
+ :result-mode :ignore))))))
+ (cond
+ ((null file-code)
+ (setf (image-load-time-funobjs *image*)
+ (delete funobj (image-load-time-funobjs *image*) :key #'first))
+ 'muerte::constantly-true)
+ (t (setf (extended-code function-env) file-code
+ (need-normalized-ecx-p function-env) nil
+ (function-envs funobj) (list (cons 'muerte.cl::t function-env))
+ (funobj-env funobj) funobj-env)
+ (make-compiled-funobj-pass2 funobj)
+ (let ((name (funobj-name funobj)))
+ (setf (movitz-env-named-function name) funobj)
+ name)))))
;;;;
More information about the Movitz-cvs
mailing list