[movitz-cvs] CVS update: movitz/compiler.lisp
Frode Vatvedt Fjeld
ffjeld at common-lisp.net
Wed Feb 4 15:25:16 UTC 2004
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."
More information about the Movitz-cvs
mailing list