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)))
,@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))
