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..
