Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv733
Modified Files: compiler.lisp Log Message: Working on improving &key parsing.
--- /project/movitz/cvsroot/movitz/compiler.lisp 2006/05/26 18:39:48 1.171 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2007/02/15 22:00:58 1.172 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.171 2006/05/26 18:39:48 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.172 2007/02/15 22:00:58 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -786,17 +786,16 @@ "Jumper-set ~S multiply defined." name) (setf (getf all-jumper-sets name) set)) finally - (multiple-value-bind (const-list num-jumpers jumpers-map) + (multiple-value-bind (const-list num-jumpers jumpers-map borrower-map) (layout-funobj-vector all-constants-plist all-key-args-constants all-jumper-sets - (length (borrowed-bindings funobj))) + (borrowed-bindings funobj)) (setf (movitz-funobj-num-jumpers funobj) num-jumpers (movitz-funobj-const-list funobj) const-list (movitz-funobj-num-constants funobj) (length const-list) (movitz-funobj-jumpers-map funobj) jumpers-map) - (loop for binding in (borrowed-bindings funobj) - as pos upfrom num-jumpers + (loop for (binding . pos) in borrower-map do (setf (borrowed-binding-reference-slot binding) pos)) (return funobj))))
@@ -1670,7 +1669,8 @@ (simple-instruction-p (c) (let ((c (ignore-instruction-prefixes c))) (and (listp c) - (member (car c) '(:movl :xorl :popl :cmpl :leal :andl :addl :subl))))) + (member (car c) + '(:movl :xorl :popl :pushl :cmpl :leal :andl :addl :subl))))) (register-indirect-operand (op base) (multiple-value-bind (reg off) (when (listp op) @@ -1711,6 +1711,9 @@ (preserves-register-p (i register) (let ((i (ignore-instruction-prefixes i))) (and (not (atom i)) + (not (and (eq register :esp) + (member (instruction-is i) + '(:pushl :popl)))) (or (and (simple-instruction-p i) (not (eq register (idst i)))) (instruction-is i :frame-map) @@ -1748,10 +1751,9 @@ (and x (dolist (y more t) (unless (equal x y) (return nil))))) - #+ignore (uses-stack-frame-p (c) (and (consp c) - (some #'stack-frame-operand (cdr c)))) + (some #'stack-frame-operand (cdr (ignore-instruction-prefixes c))))) (load-stack-frame-p (c &optional (op :movl)) (stack-frame-operand (twop-src c op))) (store-stack-frame-p (c &optional (op :movl)) @@ -2101,25 +2103,26 @@ ((flet ((try (place register &optional map reason) "See if we can remove a stack-frame load below current pc, given the knowledge that <register> is equal to <place>." - (let ((next-load (and place - (dolist (si (cdr pc)) - (when (and (twop-p si :cmpl) - (equal place (twop-src si))) - (warn "Reverse cmp not yet dealed with..")) - (cond - ((and (twop-p si :cmpl) - (equal place (twop-dst si))) - (return si)) - ((equal place (local-load-p si)) - (return si)) - ((or (not (consp si)) - (not (preserves-register-p si register)) - (equal place (twop-dst si))) - (return nil))) - (setf map - (remove-if (lambda (m) - (not (preserves-register-p si (cdr m)))) - map)))))) + (let ((next-load + (and place + (dolist (si (cdr pc)) + (when (and (twop-p si :cmpl) + (equal place (twop-src si))) + (warn "Reverse cmp not yet dealed with..")) + (cond + ((and (twop-p si :cmpl) + (equal place (twop-dst si))) + (return si)) + ((equal place (local-load-p si)) + (return si)) + ((or (not (consp si)) + (not (preserves-register-p si register)) + (equal place (twop-dst si))) + (return nil))) + (setf map + (remove-if (lambda (m) + (not (preserves-register-p si (cdr m)))) + map)))))) (case (instruction-is next-load) (:movl (let ((pos (position next-load pc))) @@ -2197,6 +2200,33 @@ next-pc (nthcdr 3 pc)) (explain nil "Removed redundant store before ~A: ~A" i2 (subseq pc 0 3))) + #+ignore + ((let ((stack-pos (store-stack-frame-p i))) + (and stack-pos + (loop with search-pc = (cdr pc) + while search-pc + repeat 10 + for ii = (pop search-pc) + thereis (eql stack-pos + (store-stack-frame-p ii)) + while (or (global-funcall-p ii) + (and (simple-instruction-p ii) + (not (eql stack-pos + (uses-stack-frame-p ii)))))) + #+ignore + (eql stack-pos + (store-stack-frame-p i4)) + #+ignore + (every (lambda (ii) + (or (global-funcall-p ii) + (and (simple-instruction-p ii) + (not (eql stack-pos + (uses-stack-frame-p ii)))))) + (list i2 i3)))) + (setf p nil + next-pc (cdr pc)) + (explain t "removing redundant store at ~A" + (subseq pc 0 (min 10 (length pc))))) ((and (member (instruction-is i) '(:cmpl :cmpb :cmpw :testl :testb :testw)) (member (instruction-is i2) @@ -2629,7 +2659,49 @@ (and (assoc binding map) t))
(defun frame-map-size (map) - (reduce #'max map :initial-value 0 :key (lambda (x) (if (integerp (cdr x)) (cdr x) 0)))) + (reduce #'max map + :initial-value 0 + :key (lambda (x) + (if (integerp (cdr x)) + (cdr x) + 0)))) + +(defun frame-map-next-free-location (frame-map env &optional (size 1)) + (labels ((stack-location (binding) + (if (typep binding 'forwarding-binding) + (stack-location (forwarding-binding-target binding)) + (new-binding-location binding frame-map :default nil))) + (env-extant (env1 env2) + "Is env1 active whenever env2 is active?" + (cond + ((null env2) + nil) + ((eq env1 env2) + ;; (warn "~S shadowed by ~S" env env2) + t) + (t (env-extant env1 (movitz-environment-extent-uplink env2)))))) + (let ((frame-size (frame-map-size frame-map))) + (or (loop for location from 1 to frame-size + when + (loop for sub-location from location below (+ location size) + never + (find-if (lambda (b-loc) + (destructuring-bind (binding . binding-location) + b-loc + (or (and (not (bindingp binding)) + (eql sub-location binding-location)) + (and (eql sub-location (stack-location binding)) + (labels + ((z (b) + (when b + (or (env-extant (binding-env b) env) + (env-extant env (binding-env b)) + (when (typep b 'forwarding-binding) + (z (forwarding-binding-target b))))))) + (z binding)))))) + frame-map)) + return location) + (1+ frame-size))))) ; no free location found, so grow frame-size.
(define-setf-expander new-binding-location (binding map-place &environment env) (multiple-value-bind (temps values stores setter getter) @@ -2772,7 +2844,7 @@ finally (return (values non-key-constants jumper-sets key-args-constants))))))
-(defun layout-funobj-vector (constants key-args-constants jumper-sets num-borrowing-slots) +(defun layout-funobj-vector (constants key-args-constants jumper-sets borrowing-bindings) (let* ((jumpers (loop with x for set in (cdr jumper-sets) by #'cddr unless (search set x) @@ -2780,7 +2852,8 @@ finally (return x))) (num-jumpers (length jumpers))) (values (append jumpers - (make-list num-borrowing-slots :initial-element *movitz-nil*) + (make-list (length borrowing-bindings) + :initial-element *movitz-nil*) (mapcar (lambda (x) (movitz-read (car x))) (append (sort (loop for (constant count) on constants by #'cddr unless (or (eq constant *movitz-nil*) @@ -2790,7 +2863,10 @@ key-args-constants))) num-jumpers (loop for (name set) on jumper-sets by #'cddr - collect (cons name set))))) + collect (cons name set)) + (loop for borrowing-binding in borrowing-bindings + as pos upfrom num-jumpers + collect (cons borrowing-binding pos)))))
(defun movitz-funobj-intern-constant (funobj obj) ;; (error "XXXXX") @@ -3090,218 +3166,210 @@ (check-type function-env function-env) (assert (= initial-stack-frame-position (1+ (frame-map-size frame-map)))) - (let* ((env-roof-map nil) ; memoize result of assign-env-bindings + (let* ((env-assigned-p nil) ; memoize result of assign-env-bindings (flat-program code) (var-counts (discover-variables flat-program function-env))) (labels - ((env-floor (env) - (cond - ((eq env function-env) - initial-stack-frame-position) - ((typep env 'function-env) - (error "SEFEW: ~S" function-env)) - ;; The floor of this env is the roof of its extent-uplink. - (t (assign-env-bindings (movitz-environment-extent-uplink env))))) - ;; PROMOTE FORW-BINDINGS TO UPPER ENV!! - (assign-env-bindings (env) - (or (getf env-roof-map env nil) - (let* ((stack-frame-position (env-floor env)) - (bindings-to-locate - (loop for binding being the hash-keys of var-counts - when - (and (eq env (binding-extent-env binding)) - (not (let ((variable (binding-name binding))) - (cond - ((not (typep binding 'lexical-binding))) - ((typep binding 'lambda-binding)) - ((typep binding 'constant-object-binding)) - ((typep binding 'forwarding-binding) - ;; Immediately "assign" to target. - (when (plusp (or (car (gethash binding var-counts)) 0)) - (setf (new-binding-location binding frame-map) - (forwarding-binding-target binding))) - t) - ((typep binding 'borrowed-binding)) - ((typep binding 'funobj-binding)) - ((and (typep binding 'fixed-required-function-argument) - (plusp (or (car (gethash binding var-counts)) 0))) - (prog1 nil ; may need lending-cons - (setf (new-binding-location binding frame-map) - `(:argument-stack ,(function-argument-argnum binding))))) - ((unless (or (movitz-env-get variable 'ignore nil - (binding-env binding) nil) - (movitz-env-get variable 'ignorable nil - (binding-env binding) nil) - (typep binding 'hidden-rest-function-argument) - (third (gethash binding var-counts))) - (warn "Unused variable: ~S" - (binding-name binding)))) - ((not (plusp (or (car (gethash binding var-counts)) 0)))))))) - collect binding)) - (bindings-fun-arg-sorted - (when (eq env function-env) - (sort (copy-list bindings-to-locate) #'< - :key (lambda (binding) - (etypecase binding - (edx-function-argument 3) - (positional-function-argument - (* 2 (function-argument-argnum binding))) - (binding 100000)))))) - (bindings-register-goodness-sort + ((assign-env-bindings (env) + (unless (member env env-assigned-p) + (unless (eq env function-env) + (assign-env-bindings (movitz-environment-extent-uplink env))) + (let* ((bindings-to-locate + (loop for binding being the hash-keys of var-counts + when + (and (eq env (binding-extent-env binding)) + (not (let ((variable (binding-name binding))) + (cond + ((not (typep binding 'lexical-binding))) + ((typep binding 'lambda-binding)) + ((typep binding 'constant-object-binding)) + ((typep binding 'forwarding-binding) + (when (plusp (or (car (gethash binding var-counts)) 0)) + (assert (new-binding-located-p binding frame-map))) + t) + ((typep binding 'borrowed-binding)) + ((typep binding 'funobj-binding)) + ((and (typep binding 'fixed-required-function-argument) + (plusp (or (car (gethash binding var-counts)) 0))) + (prog1 nil ; may need lending-cons + (setf (new-binding-location binding frame-map) + `(:argument-stack ,(function-argument-argnum binding))))) + ((unless (or (movitz-env-get variable 'ignore nil + (binding-env binding) nil) + (movitz-env-get variable 'ignorable nil + (binding-env binding) nil) + (typep binding 'hidden-rest-function-argument) + (third (gethash binding var-counts))) + (warn "Unused variable: ~S" + (binding-name binding)))) + ((not (plusp (or (car (gethash binding var-counts)) 0)))))))) + collect binding)) + (bindings-fun-arg-sorted + (when (eq env function-env) (sort (copy-list bindings-to-locate) #'< - ;; Sort so as to make the most likely - ;; candidates for locating to registers - ;; be assigned first (i.e. maps to - ;; a smaller value). - :key (lambda (b) - (etypecase b - ((or constant-object-binding - forwarding-binding - borrowed-binding) - 1000) - (fixed-required-function-argument - (+ 100 (function-argument-argnum b))) - (located-binding - (let* ((count-init (gethash b var-counts)) - (count (car count-init)) - (init-pc (second count-init))) - (if (not (and count init-pc)) - 50 - (truncate - (or (position-if (lambda (i) - (member b (find-read-bindings i))) - (cdr init-pc)) - 15) - count))))))))) - #+ignore (labels ((dox (env upper) - (if (or (not env) - (not (sub-env-p env function-env))) - 0 - (let ((level (dox (funcall upper env) upper))) - (format t "~%~v{ ~}~S" level t env) - (+ level 4))))) - (warn "At ~S binding ~S:~{ ~S~}: Extent: ~A~%Bind: ~A" - stack-frame-position - env bindings-to-locate - (with-output-to-string (*standard-output*) - (dox env #'movitz-environment-extent-uplink)) - (with-output-to-string (*standard-output*) - (when bindings-to-locate - (dox (binding-env (first bindings-to-locate)) - #'movitz-environment-uplink))))) - #+ignore - (loop for binding in bindings-to-locate - do (when (binding-store-type binding) - (warn "~S => ~S" binding (binding-store-type binding))) - (when (typep (binding-store-type binding) 'lexical-binding) - (warn "binding ~S == ~S" - binding (binding-store-type binding)))) - ;; First, make several passes while trying to locate bindings - ;; into registers. - (loop repeat 100 with try-again = t and did-assign = t - do (unless (and try-again did-assign) - (return)) - do (setf try-again nil did-assign nil) - (loop for binding in bindings-fun-arg-sorted - while (or (typep binding 'register-required-function-argument) - (typep binding 'floating-required-function-argument) - (and (typep binding 'positional-function-argument) - (< (function-argument-argnum binding) - 2))) - do (unless (new-binding-located-p binding frame-map) - (multiple-value-bind (register status) - (try-locate-in-register binding var-counts - (movitz-environment-funobj function-env) - frame-map) - (cond - (register - (setf (new-binding-location binding frame-map) - register) - (setf did-assign t)) - ((eq status :not-now) - ;; (warn "Wait for ~S map ~A" binding frame-map) - (setf try-again t)) - (t (assert (eq status :never))))))) - (dolist (binding bindings-register-goodness-sort)
[1005 lines skipped]