/[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.65.2.9 by pw, Sat Mar 23 18:50:21 2002 UTC revision 1.89 by rtoy, Mon Apr 19 15:08:20 2010 UTC
# Line 18  Line 18 
18  ;;; Written by Rob MacLachlan  ;;; Written by Rob MacLachlan
19  ;;;  ;;;
20  (in-package :c)  (in-package :c)
21    (intl:textdomain "cmucl")
22    
23    
24  ;;;; Interface for obtaining results of constant folding:  ;;;; Interface for obtaining results of constant folding:
# Line 67  Line 68 
68                 ((null current) res))                 ((null current) res))
69             *empty-type*)))             *empty-type*)))
70      (:inside-block      (:inside-block
71       (node-derived-type (continuation-use cont)))))       (node-derived-type (continuation-use cont)))
72        (:unused
73         *empty-type*)))
74    
75    
76  ;;; Continuation-Derived-Type  --  Interface  ;;; Continuation-Derived-Type  --  Interface
# Line 193  Line 196 
196                       (not (eq rtype *empty-type*)))                       (not (eq rtype *empty-type*)))
197              (let ((*compiler-error-context* node))              (let ((*compiler-error-context* node))
198                (compiler-warning                (compiler-warning
199                 "New inferred type ~S conflicts with old type:~                 _N"New inferred type ~S conflicts with old type:~
200                  ~%  ~S~%*** Bug?"                  ~%  ~S~%*** Bug?"
201                 (type-specifier rtype) (type-specifier node-type))))                 (type-specifier rtype) (type-specifier node-type))))
202            (setf (node-derived-type node) int)            (setf (node-derived-type node) int)
# Line 291  Line 294 
294    (setf (component-reoptimize component) nil)    (setf (component-reoptimize component) nil)
295    (do-blocks (block component)    (do-blocks (block component)
296      (cond      (cond
297       ((or (block-delete-p block)       ((block-unreachable-p block)
           (null (block-pred block))  
           (eq (functional-kind (block-home-lambda block)) :deleted))  
298        (delete-block block))        (delete-block block))
299       (t       (t
300        (loop        (loop
# Line 304  Line 305 
305          (let ((last (block-last block)))          (let ((last (block-last block)))
306            (typecase last            (typecase last
307              (cif              (cif
308               (flush-dest (if-test last))               (let ((if-test (if-test last)))
309               (when (unlink-node last) (return)))                 ;; Don't flush an if-test if it requires a type check.
310                   (unless (memq (continuation-type-check if-test) '(nil :deleted))
311                     (return))
312                   (flush-dest if-test)
313                   (when (unlink-node last)
314                     (return))))
315              (exit              (exit
316               (when (maybe-delete-exit last) (return)))))               (when (maybe-delete-exit last)
317                   (return)))))
318    
319          (unless (join-successor-if-possible block)          (unless (join-successor-if-possible block)
320            (return)))            (return)))
321          ;;
322        (when (and (block-reoptimize block) (block-component block))        ;; Block-Component is nil for deleted blocks.
323          (assert (not (block-delete-p block)))        (when (block-component block)
324          (ir1-optimize-block block))          (cond ((block-unreachable-p block)
325                   (delete-block block))
326        (when (and (block-flush-p block) (block-component block))                (t
327          (assert (not (block-delete-p block)))                 (when (block-reoptimize block)
328          (flush-dead-code block)))))                   (ir1-optimize-block block))
329                   (when (and (block-flush-p block)
330    (undefined-value))                            (block-component block))
331                     (flush-dead-code block))))))))
332      (values))
333    
334  ;;; IR1-Optimize-Block  --  Internal  ;;; IR1-Optimize-Block  --  Internal
335  ;;;  ;;;
# Line 486  Line 494 
494               (let ((attr (function-info-attributes info)))               (let ((attr (function-info-attributes info)))
495                 (when (and (ir1-attributep attr flushable)                 (when (and (ir1-attributep attr flushable)
496                            (not (ir1-attributep attr call)))                            (not (ir1-attributep attr call)))
497                   (flush-dest (combination-fun node))                   (unless (policy node (= safety 3))
498                   (dolist (arg (combination-args node))                       ;; Don't flush calls to flushable functions when
499                     (flush-dest arg))                       ;; SAFETY=3, even if their value is unused in
500                   (unlink-node node))))))                       ;; safe code, because this means something like
501                         ;; (PROGN (FBOUNDP 42) T) won't signal an error.
502                         ;; KLUDGE: The right thing to do here is probably
503                         ;; teaching MAYBE-NEGATE-CHECK and friends to
504                         ;; accept nil continuation-dests instead of
505                         ;; faking one.  Can't be bothered at present.
506                         ;; Gerd, 2003-04-26.
507                       (flush-dest (combination-fun node))
508                       (dolist (arg (combination-args node))
509                         (flush-dest arg))
510                       (unlink-node node)))))))
511          (mv-combination          (mv-combination
512           (when (eq (basic-combination-kind node) :local)           (when (eq (basic-combination-kind node) :local)
513             (let ((fun (combination-lambda node)))             (let ((fun (combination-lambda node)))
# Line 542  Line 560 
560    (let ((result (return-result node)))    (let ((result (return-result node)))
561      (collect ((use-union *empty-type* values-type-union))      (collect ((use-union *empty-type* values-type-union))
562        (do-uses (use result)        (do-uses (use result)
563          (cond ((and (basic-combination-p use)          (let ((use-home (node-home-lambda use)))
564                      (eq (basic-combination-kind use) :local))            (cond ((or (eq (functional-kind use-home) :deleted)
565                 (assert (eq (lambda-tail-set (node-home-lambda use))                       (block-delete-p (node-block use))))
566                             (lambda-tail-set (combination-lambda use))))                  ((and (basic-combination-p use)
567                 (when (combination-p use)                        (eq (basic-combination-kind use) :local))
568                   (when (nth-value 1 (maybe-convert-tail-local-call use))                   (assert (eq (lambda-tail-set use-home)
569                     (return-from find-result-type (undefined-value)))))                               (lambda-tail-set (combination-lambda use))))
570                (t                   (when (combination-p use)
571                 (use-union (node-derived-type use)))))                     (when (nth-value 1 (maybe-convert-tail-local-call use))
572                         (return-from find-result-type (values)))))
573                    (t
574                     (use-union (node-derived-type use))))))
575        (let ((int (values-type-intersection (continuation-asserted-type result)        (let ((int (values-type-intersection (continuation-asserted-type result)
576                                             (use-union))))                                             (use-union))))
577          (setf (return-result-type node) int))))          (setf (return-result-type node) int))))
578    (undefined-value))    (values))
579    
580    
581  ;;; IR1-Optimize-Return  --  Internal  ;;; IR1-Optimize-Return  --  Internal
# Line 615  Line 636 
636          (when (immediately-used-p test use)          (when (immediately-used-p test use)
637            (convert-if-if use node)            (convert-if-if use node)
638            (when (continuation-use test) (return)))))            (when (continuation-use test) (return)))))
639        ;;
640      (let* ((type (continuation-type test))      ;; Don't flush if-tests when they require a type check.
641             (victim      (when (memq (continuation-type-check test) '(nil :deleted))
642              (cond ((constant-continuation-p test)        (let* ((type (continuation-type test))
643                     (if (continuation-value test)               (victim
644                         (if-alternative node)                (cond ((constant-continuation-p test)
645                         (if-consequent node)))                       (if (continuation-value test)
646                    ((not (types-intersect type *null-type*))                           (if-alternative node)
647                     (if-alternative node))                           (if-consequent node)))
648                    ((type= type *null-type*)                      ((not (types-intersect type *null-type*))
649                     (if-consequent node)))))                       (if-alternative node))
650        (when victim                      ((type= type *null-type*)
651          (flush-dest test)                       (if-consequent node)))))
652          (when (rest (block-succ block))          (when victim
653            (unlink-blocks block victim))            (flush-dest test)
654          (setf (component-reanalyze (block-component (node-block node))) t)            (when (rest (block-succ block))
655          (unlink-node node))))              (unlink-blocks block victim))
656              (setf (component-reanalyze (block-component (node-block node))) t)
657              (unlink-node node)))))
658    (undefined-value))    (undefined-value))
659    
660    
# Line 723  Line 746 
746                  (when (and (basic-combination-p use)                  (when (and (basic-combination-p use)
747                             (eq (basic-combination-kind use) :local))                             (eq (basic-combination-kind use) :local))
748                    (merges use))))                    (merges use))))
749                (when (null (continuation-dest cont))
750                  (flush-dest value))
751              (substitute-continuation-uses cont value)              (substitute-continuation-uses cont value)
752              (dolist (merge (merges))              (dolist (merge (merges))
753                (merge-tail-sets merge))))))))                (merge-tail-sets merge))))))))
# Line 758  Line 783 
783           (when arg           (when arg
784             (setf (continuation-reoptimize arg) nil)))             (setf (continuation-reoptimize arg) nil)))
785    
786           (let ((fun (function-info-result-not-used kind)))
787             (when fun
788               (let ((unused-result (funcall fun node)))
789                 (when unused-result
790                   (let ((*compiler-error-context* node))
791                     (compiler-warning _N"The return value of ~A should not be discarded."
792                                       (continuation-function-name (basic-combination-fun node))))))))
793    
794           (let ((fun (function-info-destroyed-constant-args kind)))
795             (when fun
796               (let ((destroyed-constant-args (funcall fun args)))
797                 (when destroyed-constant-args
798                   (let ((*compiler-error-context* node))
799                     (warn 'kernel:constant-modified
800                           :function-name (continuation-function-name
801                                           (basic-combination-fun node)))
802                     (setf (basic-combination-kind node) :error)
803                     (return-from ir1-optimize-combination))))))
804    
805         (let ((attr (function-info-attributes kind)))         (let ((attr (function-info-attributes kind)))
806           (when (and (ir1-attributep attr foldable)           (when (and (ir1-attributep attr foldable)
807                      (not (ir1-attributep attr call))                      (not (ir1-attributep attr call))
# Line 860  Line 904 
904    (declare (type combination call))    (declare (type combination call))
905    (let* ((ref (continuation-use (basic-combination-fun call)))    (let* ((ref (continuation-use (basic-combination-fun call)))
906           (leaf (when (ref-p ref) (ref-leaf ref)))           (leaf (when (ref-p ref) (ref-leaf ref)))
907           (inlinep (if (and (defined-function-p leaf)           (inlinep (if (defined-function-p leaf)
                            (not (byte-compiling)))  
908                        (defined-function-inlinep leaf)                        (defined-function-inlinep leaf)
909                        :no-chance)))                        :no-chance)))
910        (when (and (or (byte-compiling)
911                       *converting-for-interpreter*)
912                   (member inlinep '(:inline :maybe-inline)))
913          (setq inlinep :notinline))
914      (cond      (cond
915       ((eq inlinep :notinline) (values nil nil))       ((eq inlinep :notinline) (values nil nil))
916       ((not (and (global-var-p leaf)       ((not (and (global-var-p leaf)
# Line 965  Line 1012 
1012                  (convert-call-if-possible                  (convert-call-if-possible
1013                   (continuation-use (basic-combination-fun call))                   (continuation-use (basic-combination-fun call))
1014                   call))                   call))
1015                 ((not leaf))                 ((not (and leaf info)))
1016                 ((or (info function source-transform (leaf-name leaf))                 ((or (info function source-transform (leaf-name leaf))
1017                      (and info                      (and (ir1-attributep (function-info-attributes info)
                          (ir1-attributep (function-info-attributes info)  
1018                                           predicate)                                           predicate)
1019                           (let ((dest (continuation-dest (node-cont call))))                           (let ((dest (continuation-dest (node-cont call))))
1020                             (and dest (not (if-p dest))))))                             (and dest (not (if-p dest))))))
# Line 1145  Line 1191 
1191        (local-call-analyze *current-component*)))        (local-call-analyze *current-component*)))
1192    (undefined-value))    (undefined-value))
1193    
   
1194  ;;; Constant-Fold-Call  --  Internal  ;;; Constant-Fold-Call  --  Internal
1195  ;;;  ;;;
1196  ;;;    Replace a call to a foldable function of constant arguments with the  ;;;    Replace a call to a foldable function of constant arguments with the
# Line 1165  Line 1210 
1210           (fun (leaf-name (ref-leaf ref))))           (fun (leaf-name (ref-leaf ref))))
1211    
1212      (multiple-value-bind (values win)      (multiple-value-bind (values win)
1213                           (careful-call fun args call "constant folding")          (careful-call fun args call "constant folding")
1214        (cond        (cond ((not win)
1215         ((not win)               (setf (combination-kind call) :error))
1216          (setf (combination-kind call) :error))              ;;
1217         ;; X Always transform the call below so that non-flushable              ;; Don't constand-fold a call if one of its arguments
1218         ;; functions get flushed if the constant folding works.              ;; requires a type check.
1219         #+nil              ((or (policy call (< safety 3))
1220         ((= (length values) 1)                   (loop for arg in (basic-combination-args call)
1221          (with-ir1-environment call                         as check = (continuation-type-check arg)
1222            (when (producing-fasl-file)                         always (member check '(nil :deleted))))
1223              (maybe-emit-make-load-forms (first values)))               (let ((dummies (loop repeat (length args) collect (gensym))))
1224            (let* ((leaf (find-constant (first values)))                 (transform-call
1225                   (node (make-ref (leaf-type leaf) leaf))                  call
1226                   (dummy (make-continuation))                  `(lambda ,dummies
1227                   (cont (node-cont call))                     (declare (ignore ,@dummies))
1228                   (block (node-block call))                     (values ,@(mapcar (lambda (x) `',x) values)))))))))
1229                   (next (continuation-next cont)))    (values))
             (push node (leaf-refs leaf))  
             (setf (leaf-ever-used leaf) t)  
   
             (delete-continuation-use call)  
             (add-continuation-use call dummy)  
             (prev-link node dummy)  
             (add-continuation-use node cont)  
             (setf (continuation-next cont) next)  
             (when (eq call (block-last block))  
               (setf (block-last block) node))  
             (reoptimize-continuation cont))))  
        (t  
         (let ((dummies (loop repeat (length args)  
                              collect (gensym))))  
           (transform-call  
            call  
            `(lambda ,dummies  
               (declare (ignore ,@dummies))  
               (values ,@(mapcar #'(lambda (x) `',x) values)))))))))  
   
   (undefined-value))  
1230    
1231    
1232  ;;;; Local call optimization:  ;;;; Local call optimization:
# Line 1630  Line 1654 
1654          (when total-nvals          (when total-nvals
1655            (when (and min (< total-nvals min))            (when (and min (< total-nvals min))
1656              (compiler-warning              (compiler-warning
1657               "MULTIPLE-VALUE-CALL with ~R values when the function expects ~               _N"MULTIPLE-VALUE-CALL with ~R values when the function expects ~
1658               at least ~R."               at least ~R."
1659               total-nvals min)               total-nvals min)
1660              (setf (basic-combination-kind node) :error)              (setf (basic-combination-kind node) :error)
1661              (return-from ir1-optimize-mv-call))              (return-from ir1-optimize-mv-call))
1662            (when (and max (> total-nvals max))            (when (and max (> total-nvals max))
1663              (compiler-warning              (compiler-warning
1664               "MULTIPLE-VALUE-CALL with ~R values when the function expects ~               _N"MULTIPLE-VALUE-CALL with ~R values when the function expects ~
1665               at most ~R."               at most ~R."
1666               total-nvals max)               total-nvals max)
1667              (setf (basic-combination-kind node) :error)              (setf (basic-combination-kind node) :error)
# Line 1654  Line 1678 
1678                       (fun (ir1-convert-lambda                       (fun (ir1-convert-lambda
1679                             `(lambda (&optional ,@dums &rest ,ignore)                             `(lambda (&optional ,@dums &rest ,ignore)
1680                                (declare (ignore ,ignore))                                (declare (ignore ,ignore))
1681                                (funcall ,(ref-leaf ref) ,@dums)))))                                (funcall ,(ref-leaf ref) ,@dums))
1682                               nil          ; name
1683                               nil          ; parent-form
1684                               nil          ; allow-debug-catch-tag
1685                               'ir1-optimize-mv-call ; caller
1686                               )))
1687                  (change-ref-leaf ref fun)                  (change-ref-leaf ref fun)
1688                  (assert (eq (basic-combination-kind node) :full))                  (assert (eq (basic-combination-kind node) :full))
1689                  (local-call-analyze *current-component*)                  (local-call-analyze *current-component*)

Legend:
Removed from v.1.65.2.9  
changed lines
  Added in v.1.89

  ViewVC Help
Powered by ViewVC 1.1.5