Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv10563

Modified Files: compiler.lisp Log Message: For funobjs with &key arguments, have the keyword constants be reliably placed in proper sequence at the tail end of the funobj-constants list. This in preparation for improved &key arguments parsing.

--- /project/movitz/cvsroot/movitz/compiler.lisp 2006/05/05 18:37:32 1.170 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2006/05/26 18:39:48 1.171 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.170 2006/05/05 18:37:32 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.171 2006/05/26 18:39:48 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -768,13 +768,18 @@

(defun finalize-funobj (funobj) "Calculate funobj's constants, jumpers." - (loop with all-constants-plist = () and all-jumper-sets = () + (loop with all-key-args-constants = nil + with all-constants-plist = () and all-jumper-sets = () for (nil . function-env) in (function-envs funobj) - ;; (borrowed-bindings body-code) in code-specs + ;; (borrowed-bindings body-code) in code-specs as body-code = (extended-code function-env) - as (const-plist jumper-sets) = + as (const-plist jumper-sets key-args-constants) = (multiple-value-list (find-code-constants-and-jumpers body-code)) - do (loop for (constant usage) on const-plist by #'cddr + do (when key-args-constants + (assert (not all-key-args-constants) () + "only one &key parsing allowed per funobj.") + (setf all-key-args-constants key-args-constants)) + (loop for (constant usage) on const-plist by #'cddr do (incf (getf all-constants-plist constant 0) usage)) (loop for (name set) on jumper-sets by #'cddr do (assert (not (getf all-jumper-sets name)) () @@ -783,6 +788,7 @@ finally (multiple-value-bind (const-list num-jumpers jumpers-map) (layout-funobj-vector all-constants-plist + all-key-args-constants all-jumper-sets (length (borrowed-bindings funobj))) (setf (movitz-funobj-num-jumpers funobj) num-jumpers @@ -2704,7 +2710,7 @@

(defun find-code-constants-and-jumpers (code &key include-programs) "Return code's constants (a plist of constants and their usage-counts) and jumper-sets." - (let (jumper-sets constants) + (let (jumper-sets constants key-args-set) (labels ((process-binding (binding) "Some bindings are really references to constants." (typecase binding @@ -2743,6 +2749,8 @@ (assert (not (getf jumper-sets name)) () "Duplicate jumper declaration for ~S." name) (setf (getf jumper-sets name) set))) + (:declare-key-arg-set + (setf key-args-set (cdr instruction))) (t (when (listp instruction) (dolist (binding (find-read-bindings instruction)) (process-binding binding))))) @@ -2750,9 +2758,21 @@ (when sub (process sub)))))) (process code) (map nil #'process include-programs)) - (values constants jumper-sets))) + (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))))))

-(defun layout-funobj-vector (constants jumper-sets num-borrowing-slots) +(defun layout-funobj-vector (constants key-args-constants jumper-sets num-borrowing-slots) (let* ((jumpers (loop with x for set in (cdr jumper-sets) by #'cddr unless (search set x) @@ -2762,11 +2782,12 @@ (values (append jumpers (make-list num-borrowing-slots :initial-element *movitz-nil*) (mapcar (lambda (x) (movitz-read (car x))) - (sort (loop for (constant count) on constants by #'cddr - unless (or (eq constant *movitz-nil*) - (eq constant (image-t-symbol *image*))) - collect (cons constant count)) - #'< :key #'cdr))) + (append (sort (loop for (constant count) on constants by #'cddr + unless (or (eq constant *movitz-nil*) + (eq constant (image-t-symbol *image*))) + collect (cons constant count)) + #'< :key #'cdr) + key-args-constants))) num-jumpers (loop for (name set) on jumper-sets by #'cddr collect (cons name set))))) @@ -2808,6 +2829,8 @@ (t (case (instruction-is i) ((nil) (return nil)) ; a label, most likely + ((:declare-key-arg-set :declare-label-set) + nil) ((:lexical-control-transfer :load-lambda) (return nil)) ; not sure about these. ((:call) @@ -4014,7 +4037,9 @@ (list* (append pf (car sub-instr)) (cdr sub-instr))) (t (list* pf sub-instr)))))))) - (:declare-label-set nil) + ((:declare-label-set + :declare-key-arg-set) + nil) (:local-function-init (destructuring-bind (function-binding) (operands instruction) @@ -4956,63 +4981,72 @@ (t #+ignore (pushnew (movitz-print (movitz-funobj-name funobj)) (aref *xx* (length 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))) - ,@(compiler-call #'compile-form - :form (optional-function-argument-init-form binding) - :env env - :funobj funobj - :result-mode binding) - ,keyword-ok-label) - else append - (append (when supplied-p-var - `((:init-lexvar ,supplied-p-binding - :init-with-register :edi - :init-with-type null))) - (compiler-call #'compile-form - :form (list 'muerte.cl:quote - (eval-form (optional-function-argument-init-form binding) - env)) - :env env - :funobj funobj - :result-mode :eax) - `((:load-constant - ,(movitz-read (keyword-function-argument-keyword-name binding)) :ecx) - (:load-lexical ,rest-binding :ebx) - (:call (:edi ,(global-constant-offset 'keyword-search)))) - (when supplied-p-var - `((:jz ',keyword-not-supplied-label) - (:movl (:edi ,(global-constant-offset 't-symbol)) :ebx) - (:store-lexical ,supplied-p-binding :ebx - :type (eql ,(image-t-symbol *image*))) - ,keyword-not-supplied-label)) - `((:init-lexvar ,binding - :init-with-register :eax - :init-with-type t))))))) + #+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))) + ,@(compiler-call #'compile-form + :form (optional-function-argument-init-form binding) + :env env + :funobj funobj + :result-mode binding) + ,keyword-ok-label) + else append + (append (when supplied-p-var + `((:init-lexvar ,supplied-p-binding + :init-with-register :edi + :init-with-type null))) + (compiler-call #'compile-form + :form (list 'muerte.cl:quote + (eval-form (optional-function-argument-init-form binding) + env)) + :env env + :funobj funobj + :result-mode :eax) + `((:load-constant + ,(movitz-read (keyword-function-argument-keyword-name binding)) :ecx) + (:load-lexical ,rest-binding :ebx) + (:call (:edi ,(global-constant-offset 'keyword-search)))) + (when supplied-p-var + `((:jz ',keyword-not-supplied-label) + (:movl (:edi ,(global-constant-offset 't-symbol)) :ebx) + (:store-lexical ,supplied-p-binding :ebx + :type (eql ,(image-t-symbol *image*))) + ,keyword-not-supplied-label)) + `((:init-lexvar ,binding + :init-with-register :eax + :init-with-type t)))))))) need-normalized-ecx-p)))

(defun make-special-funarg-shadowing (env function-body)