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]
