/[cmucl]/src/compiler/ir1opt.lisp
ViewVC logotype

Diff of /src/compiler/ir1opt.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.27 by ram, Thu May 16 00:25:56 1991 UTC revision 1.28 by ram, Thu Oct 3 18:30:28 1991 UTC
# Line 702  Line 702 
702         (let ((fun (function-info-optimizer kind)))         (let ((fun (function-info-optimizer kind)))
703           (unless (and fun (funcall fun node))           (unless (and fun (funcall fun node))
704             (dolist (x (function-info-transforms kind))             (dolist (x (function-info-transforms kind))
705               (unless (ir1-transform node (car x) (cdr x))               (unless (ir1-transform node x)
706                 (return))))))))                 (return))))))))
707    
708    (undefined-value))    (undefined-value))
# Line 801  Line 801 
801    
802  ;;;  ;;;
803  ;;;    A hashtable from combination nodes to things describing how an  ;;;    A hashtable from combination nodes to things describing how an
804  ;;; optimization of the node failed.  The value is an alist  ;;; optimization of the node failed.  The value is an alist (Transform . Args),
805  ;;; (Fun . Args), where Fun is the transformation function that failed and Args  ;;; where Transform is the structure describing the transform that failed, and
806  ;;; is either a list for format arguments for the note or the FUNCTION-TYPE  ;;; Args is either a list of format arguments for the note, or the
807  ;;; that would have enabled the transformation but failed to match.  ;;; FUNCTION-TYPE that would have enabled the transformation but failed to
808    ;;; match.
809  ;;;  ;;;
810  (defvar *failed-optimizations* (make-hash-table :test #'eq))  (defvar *failed-optimizations* (make-hash-table :test #'eq))
811    
# Line 812  Line 813 
813  ;;; RECORD-OPTIMIZATION-FAILURE  --  Internal  ;;; RECORD-OPTIMIZATION-FAILURE  --  Internal
814  ;;;  ;;;
815  ;;;    Add a failed optimization note to *FAILED-OPTIMZATIONS* for Node, Fun  ;;;    Add a failed optimization note to *FAILED-OPTIMZATIONS* for Node, Fun
816  ;;; and Args.  If there is already a note for Node and Fun, replace it,  ;;; and Args.  If there is already a note for Node and Transform, replace it,
817  ;;; otherwise add a new one.  ;;; otherwise add a new one.
818  ;;;  ;;;
819  (defun record-optimization-failure (node fun args)  (defun record-optimization-failure (node transform args)
820    (declare (type combination node) (type function fun)    (declare (type combination node) (type transform transform)
821             (type (or function-type list) args))             (type (or function-type list) args))
822    (let ((found (assoc fun (gethash node *failed-optimizations*))))    (let ((found (assoc transform (gethash node *failed-optimizations*))))
823      (if found      (if found
824          (setf (cdr found) args)          (setf (cdr found) args)
825          (push (cons fun args)          (push (cons transform args)
826                (gethash node *failed-optimizations*))))                (gethash node *failed-optimizations*))))
827    (undefined-value))    (undefined-value))
828    
# Line 836  Line 837 
837  ;;; attempted.  We return false if either the transform suceeded or was  ;;; attempted.  We return false if either the transform suceeded or was
838  ;;; aborted.  ;;; aborted.
839  ;;;  ;;;
840  (defun ir1-transform (node type fun)  (defun ir1-transform (node transform)
841    (declare (type combination node) (type ctype type) (type function fun))    (declare (type combination node) (type transform transform))
842    (let ((constrained (function-type-p type))    (let* ((type (transform-type transform))
843          (flame (policy node (> speed brevity)))           (fun (transform-function transform))
844          (*compiler-error-context* node))           (constrained (function-type-p type))
845             (flame (policy node (> speed brevity)))
846             (*compiler-error-context* node))
847      (cond ((or (not constrained)      (cond ((or (not constrained)
848                 (valid-function-use node type :strict-result t))                 (valid-function-use node type :strict-result t))
849             (multiple-value-bind             (multiple-value-bind
# Line 863  Line 866 
866                 (:failure                 (:failure
867                  (if args                  (if args
868                      (when flame                      (when flame
869                        (record-optimization-failure node fun args))                        (record-optimization-failure node transform args))
870                      (setf (gethash node *failed-optimizations*)                      (setf (gethash node *failed-optimizations*)
871                            (remove fun (gethash node *failed-optimizations*)                            (remove transform
872                                      (gethash node *failed-optimizations*)
873                                    :key #'car)))                                    :key #'car)))
874                  t))))                  t))))
875            ((and flame            ((and flame
876                  (valid-function-use node type                  (valid-function-use node type
877                                      :argument-test #'types-intersect                                      :argument-test #'types-intersect
878                                      :result-test #'values-types-intersect))                                      :result-test #'values-types-intersect))
879             (record-optimization-failure node fun type)             (record-optimization-failure node transform type)
880             t)             t)
881            (t            (t
882             t))))             t))))

Legend:
Removed from v.1.27  
changed lines
  Added in v.1.28

  ViewVC Help
Powered by ViewVC 1.1.5