Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv30554
Modified Files:
compiler.lisp
Log Message:
First implementation of new &key-parsing strategy.
--- /project/movitz/cvsroot/movitz/compiler.lisp 2007/02/17 19:24:28 1.174
+++ /project/movitz/cvsroot/movitz/compiler.lisp 2007/02/19 20:24:38 1.175
@@ -8,7 +8,7 @@
;;;; Created at: Wed Oct 25 12:30:49 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
-;;;; $Id: compiler.lisp,v 1.174 2007/02/17 19:24:28 ffjeld Exp $
+;;;; $Id: compiler.lisp,v 1.175 2007/02/19 20:24:38 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
@@ -789,6 +789,9 @@
(multiple-value-bind (const-list num-jumpers jumpers-map borrower-map)
(layout-funobj-vector all-constants-plist
all-key-args-constants
+ #+ignore (mapcar (lambda (x)
+ (cons (movitz-read x) 1))
+ '(:a :b :c :d))
all-jumper-sets
(borrowed-bindings funobj))
(setf (movitz-funobj-num-jumpers funobj) num-jumpers
@@ -2655,7 +2658,7 @@
(defun make-binding-map () nil)
(defun new-binding-located-p (binding map)
- (check-type binding (or binding (cons keyword binding)))
+ (check-type binding (or null binding (cons keyword binding)))
(and (assoc binding map) t))
(defun frame-map-size (map)
@@ -2830,19 +2833,9 @@
(when sub (process sub))))))
(process code)
(map nil #'process include-programs))
- (if (not key-args-set)
- (values constants jumper-sets nil)
- (loop with key-args-constants = nil
- for (object count) on constants by #'cddr
- if (not (member object key-args-set))
- append (list object count) into non-key-constants
- else
- do (setf key-args-constants
- (merge 'list key-args-constants (list (cons object count)) #'<
- :key (lambda (x)
- (position (car x) key-args-set))))
- finally
- (return (values non-key-constants jumper-sets key-args-constants))))))
+ (loop for key-arg in key-args-set
+ do (remf constants key-arg))
+ (values constants jumper-sets key-args-set)))
(defun layout-funobj-vector (constants key-args-constants jumper-sets borrowing-bindings)
(let* ((jumpers (loop with x
@@ -2851,7 +2844,12 @@
do (setf x (nconc x (copy-list set)))
finally (return x)))
(num-jumpers (length jumpers))
- (stuff (append key-args-constants
+ (stuff (append (mapcar (lambda (c)
+ (cons c 1))
+ key-args-constants)
+ (when key-args-constants
+ (list (cons (movitz-read 0)
+ 1)))
(sort (loop for (constant count) on constants by #'cddr
unless (or (eq constant *movitz-nil*)
(eq constant (image-t-symbol *image*)))
@@ -3136,9 +3134,11 @@
(funobj-binding))))
(:init-lexvar
(destructuring-bind (binding &key init-with-register init-with-type
- protect-registers protect-carry)
+ protect-registers protect-carry
+ shared-reference-p)
(cdr instruction)
- (declare (ignore protect-registers protect-carry init-with-type))
+ (declare (ignore protect-registers protect-carry init-with-type
+ shared-reference-p))
(cond
((not init-with-register)
(take-note-of-init binding pc))
@@ -3320,6 +3320,9 @@
(when (and (binding-lended-p binding)
(not (typep binding 'borrowed-binding))
(not (getf (binding-lending binding) :stack-cons-location)))
+ #+ignore
+ (assert (not (typep binding 'keyword-function-argument)) ()
+ "Can't lend keyword binding ~S." binding)
;; (warn "assigning lending-cons for ~W at ~D" binding stack-frame-position)
(let ((cons-pos (frame-map-next-free-location frame-map function-env 2)))
(setf (new-binding-location (cons :lended-cons binding) frame-map)
@@ -3346,6 +3349,40 @@
(plusp (car (gethash binding var-counts '(0)))))
(setf (new-binding-location binding frame-map)
(forwarding-binding-target binding))))
+ ;; Keyword bindings
+ (flet ((set-exclusive-location (binding location)
+ (assert (not (rassoc location frame-map))
+ () "Fixed location ~S for ~S is taken by ~S."
+ location binding (rassoc location frame-map))
+ (setf (new-binding-location binding frame-map) location)))
+ (when (key-vars-p function-env)
+ (when (= 0 (rest-args-position function-env))
+ (set-exclusive-location (loop for var in (required-vars function-env)
+ as binding = (movitz-binding var function-env nil)
+ thereis (when (= 0 (function-argument-argnum binding))
+ binding))
+ 1))
+ (when (>= 1 (rest-args-position function-env))
+ (set-exclusive-location (loop for var in (required-vars function-env)
+ as binding = (movitz-binding var function-env nil)
+ thereis (when (= 1 (function-argument-argnum binding))
+ binding))
+ 2)))
+ (loop for key-var in (key-vars function-env)
+ as key-binding =
+ (or (movitz-binding key-var function-env nil)
+ (error "No binding for key-var ~S." key-var))
+ as supplied-p-binding =
+ (when (optional-function-argument-supplied-p-var key-binding)
+ (or (movitz-binding (optional-function-argument-supplied-p-var key-binding)
+ function-env nil)
+ (error "No binding for supplied-p-var ~S."
+ (optional-function-argument-supplied-p-var key-binding))))
+ as location upfrom 3 by 2
+ do (set-exclusive-location key-binding location)
+ (assert supplied-p-binding)
+ (set-exclusive-location supplied-p-binding (1+ location))))
+ ;; Now, use assing-env-bindings on the remaining bindings.
(loop for env in
(loop with z = nil
for b being the hash-keys of var-counts using (hash-value c)
@@ -4293,7 +4330,7 @@
"From a (normal) <lambda-list>, add bindings to <env>."
(let ((arg-pos 0))
(multiple-value-bind (required-vars optional-vars rest-var key-vars auxes allow-p
- min-args max-args edx-var oddeven key-p)
+ min-args max-args edx-var oddeven key-vars-p)
(decode-normal-lambda-list lambda-list)
(declare (ignore auxes))
(setf (min-args env) min-args
@@ -4356,6 +4393,8 @@
(movitz-env-add-binding env (make-instance 'supplied-p-function-argument
:name supplied-p-parameter)))
formal)))
+ (when (or rest-var key-vars-p)
+ (setf (rest-args-position env) arg-pos))
(when rest-var
(check-type rest-var symbol)
(let ((formal (shadow-when-special rest-var env)))
@@ -4363,11 +4402,30 @@
(movitz-env-add-binding env (make-instance 'rest-function-argument
:name formal
:argnum (post-incf arg-pos)))))
- (when key-p
- ;; We need to check at run-time whether keyword checking is supressed or not.
- (setf (allow-other-keys-var env)
- (movitz-env-add-binding env (make-instance 'located-binding
- :name (gensym "allow-other-keys-var-")))))
+;;; (when key-vars-p
+;;; ;; We need to check at run-time whether keyword checking is supressed or not.
+;;; (setf (allow-other-keys-var env)
+;;; (movitz-env-add-binding env (make-instance 'located-binding
+;;; :name (gensym "allow-other-keys-var-")))))
+ (when key-vars-p
+ (setf (key-vars-p env) t)
+ (when (>= 1 (rest-args-position env))
+ (let ((name (gensym "save-ebx-for-keyscan")))
+ (setf (required-vars env)
+ (append (required-vars env)
+ (list name)))
+ (movitz-env-add-binding env (make-instance 'register-required-function-argument
+ :name name
+ :argnum 1
+ :declarations '(muerte.cl:ignore)))
+ (setf (movitz-env-get name 'ignore nil env) t)))
+ (when (= 0 (rest-args-position env))
+ (let ((name (gensym "save-eax-for-keyscan")))
+ (push name (required-vars env))
+ (movitz-env-add-binding env (make-instance 'register-required-function-argument
+ :name name
+ :argnum 0))
+ (setf (movitz-env-get name 'ignore nil env) t))))
(setf (key-vars env)
(loop for spec in key-vars
with rest-var-name =
@@ -4379,21 +4437,23 @@
:argnum (post-incf arg-pos)))
name)))
collect
- (multiple-value-bind (formal keyword-name init-form supplied-p-parameter)
+ (multiple-value-bind (formal keyword-name init-form supplied-p)
(decode-keyword-formal spec)
- (setf formal (shadow-when-special formal env))
- (movitz-env-add-binding env (make-instance 'keyword-function-argument
- :name formal
- 'init-form init-form
- 'supplied-p-var supplied-p-parameter
- :keyword-name keyword-name
- :rest-var-name rest-var-name))
- (when supplied-p-parameter
- (setf supplied-p-parameter
- (shadow-when-special supplied-p-parameter env))
+ (let ((formal
+ (shadow-when-special formal env))
+ (supplied-p-parameter
+ (or supplied-p
+ (gensym "supplied-p-"))))
+ (movitz-env-add-binding env (make-instance 'keyword-function-argument
+ :name formal
+ 'init-form init-form
+ 'supplied-p-var supplied-p-parameter
+ :keyword-name keyword-name
+ :rest-var-name rest-var-name))
(movitz-env-add-binding env (make-instance 'supplied-p-function-argument
- :name supplied-p-parameter)))
- formal)))
+ :name (shadow-when-special supplied-p-parameter env)))
+ formal))))
+ #+ignore
(multiple-value-bind (key-decode-map key-decode-shift)
(best-key-encode (key-vars env))
(setf (key-decode-map env) key-decode-map
@@ -4508,7 +4568,7 @@
(edx-location
(and (edx-var env)
(new-binding-location (edx-var env) frame-map :default nil))))
- ;; (warn "l0: ~S, l1: ~S" location-0 location-1)
+ #+ignore (warn "l0: ~S, l1: ~S" location-0 location-1)
(assert (not (and location-0
(eql location-0 location-1))) ()
"Compiler bug: two bindings in same location.")
@@ -4775,8 +4835,7 @@
(required-vars (required-vars env))
(optional-vars (optional-vars env))
(rest-var (rest-var env))
- (key-vars (key-vars env))
- (allow-other-keys-p (allow-other-keys-p env)))
+ (key-vars (key-vars env)))
(when (and (not rest-var)
key-vars
(not (= 1 (length key-vars))))
@@ -4912,148 +4971,81 @@
:init-with-type list))))
(when key-vars
(play-with-keys key-vars))
- (cond
+ (when (key-vars-p env)
;; &key processing..
- ((and (not rest-var)
- (= 1 (length key-vars)))
- (let* ((key-var-name (decode-keyword-formal (first key-vars)))
- (binding (movitz-binding key-var-name env))
- (position (function-argument-argnum
- (movitz-binding (keyword-function-argument-rest-var-name binding) env)))
- (supplied-p-var (optional-function-argument-supplied-p-var binding))
- (supplied-p-binding (movitz-binding supplied-p-var env)))
- (setq need-normalized-ecx-p t)
- (cond
- ((and (movitz-constantp (optional-function-argument-init-form binding))
- (< 1 position))
- `((:init-lexvar ,binding)
- ,@(when supplied-p-var
- `((:init-lexvar ,supplied-p-binding)))
- ,@(compiler-call #'compile-form
- :form (list 'muerte.cl:quote
- (eval-form (optional-function-argument-init-form binding) env nil))
- :funobj funobj
- :env env
- :result-mode :ebx)
- ,@(when supplied-p-var
- `((:store-lexical ,supplied-p-binding :edi :type null)))
- (:arg-cmp ,(+ 2 position))
- (:jb 'default-done)
- (:movl (:ebp (:ecx 4) ,(* -4 (1- position))) :eax)
- (:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding)) :eax :op :cmpl)
- ,@(if allow-other-keys-p
- `((:jne 'default-done))
- `((:jne '(:sub-program (unknown-key) (:int 101)))))
- ,@(when supplied-p-var
- `((:movl (:edi ,(global-constant-offset 't-symbol)) :eax)
- (:store-lexical ,supplied-p-binding :eax
- :type (eql ,(image-t-symbol *image*)))))
- (:movl (:ebp (:ecx 4) ,(* -4 (1- (1+ position)))) :ebx)
- default-done
- (:store-lexical ,binding :ebx :type t)))
- (t `((:init-lexvar ,binding)
- ,@(when supplied-p-var
- `((:init-lexvar ,supplied-p-binding)))
- (:arg-cmp ,(+ 2 position))
- (:jb '(:sub-program (default)
- ,@(append
- (when supplied-p-var
- `((:store-lexical ,supplied-p-binding :edi
- :type null)))
- (compiler-call #'compile-form
- :form (optional-function-argument-init-form binding)
- :funobj funobj
- :env env
- :result-mode :ebx)
- `((:jmp 'default-done)))))
- ,@(case position
- (0 `((:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding))
- :eax :op :cmpl)))
- (1 `((:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding))
- :ebx :op :cmpl)))
- (t `((:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding))
- :eax :op :cmpl))))
- ,@(if allow-other-keys-p
- `((:jne 'default))
- `((:jne '(:sub-program (unknown-key) (:int 101)))))
- ,@(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 position
- (0 nil) ; it's already in ebx
- (t `((:movl (:ebp (:ecx 4) ,(* -4 (1- (1+ position)))) :ebx))))
- default-done
- (:store-lexical ,binding :ebx :type t))))))
- (t #+ignore
- (pushnew (movitz-print (movitz-funobj-name funobj))
- (aref *xx* (length key-vars)))
- #+ignore
- (when key-vars
- (warn "KEY-FUN: ~D" (length key-vars)))
- (append
- `((:declare-key-arg-set ,@(mapcar (lambda (k)
- (movitz-read
- (keyword-function-argument-keyword-name
- (movitz-binding (decode-keyword-formal k) env))))
- key-vars)))
- (loop with rest-binding = (movitz-binding rest-var env)
- for key-var in key-vars
- as key-var-name = (decode-keyword-formal key-var)
- as binding = (movitz-binding key-var-name env)
- as supplied-p-var = (optional-function-argument-supplied-p-var binding)
- as supplied-p-binding = (movitz-binding supplied-p-var env)
- and keyword-ok-label = (make-symbol (format nil "keyword-~A-ok" key-var-name))
- and keyword-not-supplied-label = (gensym)
- do (assert binding)
- if (not (movitz-constantp (optional-function-argument-init-form binding)))
- append
- `((:init-lexvar ,binding)
- (:load-constant ,(movitz-read (keyword-function-argument-keyword-name binding)) :ecx)
- (:load-lexical ,rest-binding :ebx)
- (:call (:edi ,(global-constant-offset 'keyword-search)))
- (:jz ',keyword-not-supplied-label)
- (:store-lexical ,binding :eax :type t)
- ,@(when supplied-p-var
- `((:movl (:edi ,(global-constant-offset 't-symbol)) :eax)
- (:init-lexvar ,supplied-p-binding
- :init-with-register :eax
- :init-with-type (eql ,(image-t-symbol *image*)))))
- (:jmp ',keyword-ok-label)
- ,keyword-not-supplied-label
- ,@(when supplied-p-var
- `((:store-lexical ,supplied-p-binding :edi :type null)))
+ (setq need-normalized-ecx-p t)
+ (append
+ `((:declare-key-arg-set ,@(mapcar (lambda (k)
+ (movitz-read
+ (keyword-function-argument-keyword-name
+ (movitz-binding (decode-keyword-formal k) env))))
+ key-vars)))
+ (make-immediate-move (* +movitz-fixnum-factor+
+ (rest-args-position env))
+ :edx)
+ `((:call (:edi ,(global-constant-offset 'decode-keyargs-default))))
+ (unless (allow-other-keys-p env)
+ `((:testl :eax :eax)
+ (:jnz '(:sub-program (unknown-keyword)
+ (:int 72)))))
+ (loop for key-var in key-vars
+ as key-location upfrom 3 by 2
+ as key-var-name =
+ (decode-keyword-formal key-var)
+ as binding =
+ (movitz-binding key-var-name env)
+ as supplied-p-binding =
+ (movitz-binding (optional-function-argument-supplied-p-var binding)
+ env)
+ as keyword-ok-label = (make-symbol (format nil "keyword-~A-ok" key-var-name))
+ do (assert binding)
+ ;; (not (movitz-constantp (optional-function-argument-init-form binding)))
+ append
+ `((:init-lexvar ,binding
+ :init-with-register ,binding
+ :init-with-type t
+ :shared-reference-p t)
+ (:init-lexvar ,supplied-p-binding
+ :init-with-register ,supplied-p-binding
+ :init-with-type t
+ :shared-reference-p t))
+ append
+ (when (optional-function-argument-init-form binding)
+ `((:cmpl :edi (:ebp ,(stack-frame-offset (1+ key-location))))
+ (:jne ',keyword-ok-label)
,@(compiler-call #'compile-form
:form (optional-function-argument-init-form binding)
[187 lines skipped]
