Update of /project/movitz/cvsroot/movitz In directory clnet:/tmp/cvs-serv27877
Modified Files: compiler.lisp Log Message: Remove bad peephole optimized heuristic. Improved movitz-eql.
--- /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/21 19:45:36 1.204 +++ /project/movitz/cvsroot/movitz/compiler.lisp 2008/04/27 19:07:33 1.205 @@ -8,7 +8,7 @@ ;;;; Created at: Wed Oct 25 12:30:49 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: compiler.lisp,v 1.204 2008/04/21 19:45:36 ffjeld Exp $ +;;;; $Id: compiler.lisp,v 1.205 2008/04/27 19:07:33 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -236,28 +236,32 @@ ;; The ability to provide funobj's identity is important when a ;; function must be referenced before it can be compiled, e.g. for ;; 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 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 - ((let ((sub-form (cddr form))) - (and (consp (car sub-form)) - (eq 'muerte::numargs-case (caar sub-form)))) - '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 edx-var)) - 'make-compiled-function-pass1-1req1opt) - (t 'make-compiled-function-pass1)) - name lambda-list declarations form env top-level-p funobj)))) + (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 + ((let ((sub-form (cddr form))) + (and (consp (car sub-form)) + (eq 'muerte::numargs-case (caar sub-form)))) + '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 edx-var)) + 'make-compiled-function-pass1-1req1opt) + (t 'make-compiled-function-pass1)) + name + lambda-list + declarations + form + env + top-level-p + funobj)))
(defun ensure-pass1-funobj (funobj class &rest init-args) "If funobj is nil, return a fresh funobj of class. @@ -1880,14 +1884,14 @@ (case (instruction-is next-load) (:movl (let ((pos (position next-load pc))) - (setq p (nconc (subseq pc 0 pos) - (if (or (eq register (twop-dst next-load)) - (find-if (lambda (m) - (and (eq (twop-dst next-load) (cdr m)) - (= (car m) (stack-frame-operand place)))) - map)) - nil - (list `(:movl ,register ,(twop-dst next-load))))) + (setq p (append (subseq pc 0 pos) + (if (or (eq register (twop-dst next-load)) + (find-if (lambda (m) + (and (eq (twop-dst next-load) (cdr m)) + (= (car m) (stack-frame-operand place)))) + map)) + nil + (list `(:movl ,register ,(twop-dst next-load))))) next-pc (nthcdr (1+ pos) pc)) (explain nil "preserved load/store .. load ~S of place ~S because ~S." next-load place reason))) @@ -2141,14 +2145,6 @@ (setq p `((:call (:edi ,(global-constant-offset newf)))) next-pc (nthcdr 2 pc)) (explain nil "Changed [~S ~S] to ~S" i i2 newf))) - ((and (equal i '(:movl :eax :ebx)) - (global-funcall-p i2 '(fast-car-ebx fast-cdr-ebx))) - (let ((newf (ecase (global-funcall-p i2 '(fast-car-ebx fast-cdr-ebx)) - (fast-car-ebx 'fast-car) - (fast-cdr-ebx 'fast-cdr)))) - (setq p `((:call (:edi ,(global-constant-offset newf)))) - next-pc (nthcdr 2 pc)) - (explain nil "Changed [~S ~S] to ~S" i i2 newf))) #+ignore ((and (global-funcall-p i '(fast-cdr)) (global-funcall-p i2 '(fast-cdr)) @@ -4426,6 +4422,10 @@ ((eql 1 location-1) (decf stack-setup-size) '((:pushl :ebx))) + ((eql 2 location-1) + (decf stack-setup-size 2) + `((:pushl :edi) + (:pushl :ebx))) (t (ecase location-1 ((nil :ebx) nil) (:edx '((:movl :ebx :edx))) @@ -4490,7 +4490,7 @@ (append (cond ;; normalize arg-count in ecx.. ((and max-args (= min-args max-args)) - (error "huh?")) + (error "huh? max: ~S, min: ~S" max-args min-args)) ((and max-args (<= 0 min-args max-args #x7f)) `((:andl #x7f :ecx))) ((>= min-args #x80) @@ -6967,7 +6967,9 @@ (make-store-lexical destination loc0 nil funobj frame-map)) ((integerp loc0) (make-load-lexical term0 destination funobj nil frame-map)) - (t (break "Unknown Y zero-add: ~S" instruction)))) + ((type-specifier-singleton type0) + (make-load-lexical term0 destination funobj nil frame-map)) + (t (break "Unknown Y zero-add: ~S for ~S/~S => ~S" instruction term0 loc0 destination)))) ((and (movitz-subtypep type0 'fixnum) (movitz-subtypep type1 'fixnum) (movitz-subtypep result-type 'fixnum)) @@ -7203,6 +7205,29 @@
;;;;;;;
+(defun movitz-eql (x y) + "Emulate EQL on movitz-objects." + (etypecase x + (movitz-immediate-object + (and (typep y 'movitz-immediate-object) + (eql (movitz-immediate-value x) + (movitz-immediate-value y)))) + ((or movitz-symbol movitz-null movitz-cons movitz-basic-vector) + (eq x y)) + (movitz-struct + (cond + ((not (typep y 'movitz-struct)) + nil) + ((eq (movitz-struct-class x) + (muerte::movitz-find-class 'muerte.cl:complex)) + (and (eq (movitz-struct-class x) + (muerte::movitz-find-class 'muerte.cl:complex)) + (movitz-eql (first (movitz-struct-slot-values x)) + (first (movitz-struct-slot-values y))) + (movitz-eql (second (movitz-struct-slot-values x)) + (second (movitz-struct-slot-values y))))) + (t (error "movitz-eql unknown movitz-struct: ~S" x)))))) + (define-find-read-bindings :eql (x y mode) (declare (ignore mode)) (list x y)) @@ -7239,11 +7264,8 @@ (make-load-lexical y :ebx funobj nil frame-map))))) (cond ((and x-singleton y-singleton) - (let ((eql (etypecase (car x-singleton) - (movitz-immediate-object - (and (typep (car y-singleton) 'movitz-immediate-object) - (eql (movitz-immediate-value (car x-singleton)) - (movitz-immediate-value (car y-singleton)))))))) + (let ((eql (movitz-eql (car x-singleton) + (car y-singleton)))) (case (operator return-mode) (:boolean-branch-on-false (when (not eql)