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

Diff of /src/compiler/locall.lisp

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

revision 1.22 by ram, Fri Nov 15 13:41:17 1991 UTC revision 1.23 by ram, Wed Dec 11 17:14:07 1991 UTC
# Line 567  Line 567 
567  ;;;    longer in effect.  ;;;    longer in effect.
568    
569    
570    ;;; Insert-Let-Body  --  Internal
571    ;;;
572    ;;;    Set up the control transfer to the called lambda.  We split the call
573    ;;; block immediately after the call, and link the head of Fun to the call
574    ;;; block.  The successor block after splitting (where we return to) is
575    ;;; returned.
576    ;;;
577    ;;;    If the lambda is is a different component than the call, then we call
578    ;;; JOIN-COMPONENTS.  This only happens in block compilation before
579    ;;; FIND-INITIAL-DFO.
580    ;;;
581    (defun insert-let-body (fun call)
582      (declare (type clambda fun) (type basic-combination call))
583      (let* ((call-block (node-block call))
584             (bind-block (node-block (lambda-bind fun)))
585             (component (block-component call-block)))
586        (let ((fun-component (block-component bind-block)))
587          (unless (eq fun-component component)
588            (assert (eq (component-kind component) :initial))
589            (join-components component fun-component)))
590    
591        (let ((*current-component* component))
592          (node-ends-block call))
593        (assert (= (length (block-succ call-block)) 1))
594        (let ((next-block (first (block-succ call-block))))
595          (unlink-blocks call-block next-block)
596          (link-blocks call-block bind-block)
597          next-block)))
598    
599    
600  ;;; Merge-Lets  --  Internal  ;;; Merge-Lets  --  Internal
601  ;;;  ;;;
602  ;;;    Handle the environment semantics of let conversion.  We add the lambda  ;;;    Handle the environment semantics of let conversion.  We add the lambda
603  ;;; and its lets to lets for the call's home function.  We merge the calls for  ;;; and its lets to lets for the Call's home function.  We merge the calls for
604  ;;; Fun with the calls for the home function, removing Fun in the process.  We  ;;; Fun with the calls for the home function, removing Fun in the process.  We
605  ;;; also merge the Entries.  ;;; also merge the Entries.
606  ;;;  ;;;
607    ;;;   We also unlink the function head from the component head and set
608    ;;; Component-Reanalyze to true to indicate that the DFO should be recomputed.
609    ;;;
610  (defun merge-lets (fun call)  (defun merge-lets (fun call)
611    (declare (type clambda fun) (type basic-combination call))    (declare (type clambda fun) (type basic-combination call))
612    (let* ((prev (node-prev call))    (let ((component (block-component (node-block call))))
613           (home (block-home-lambda (continuation-block prev)))      (unlink-blocks (component-head component) (node-block (lambda-bind fun)))
614        (setf (component-lambdas component)
615              (delete fun (component-lambdas component)))
616        (setf (component-reanalyze component) t))
617      (setf (lambda-call-lexenv fun) (node-lexenv call))
618      (let ((tails (lambda-tail-set fun)))
619        (setf (tail-set-functions tails)
620              (delete fun (tail-set-functions tails))))
621      (setf (lambda-tail-set fun) nil)
622      (let* ((home (node-home-lambda call))
623           (home-env (lambda-environment home)))           (home-env (lambda-environment home)))
624      (push fun (lambda-lets home))      (push fun (lambda-lets home))
625      (setf (lambda-home fun) home)      (setf (lambda-home fun) home)
# Line 602  Line 644 
644    (undefined-value))    (undefined-value))
645    
646    
 ;;; Insert-Let-Body  --  Internal  
 ;;;  
 ;;;    Handle the control semantics of let conversion.  We split the call block  
 ;;; immediately after the call, and link the head and tail of Fun to the call  
 ;;; block and the following block.  We also unlink the function head and tail  
 ;;; from the component head and tail and flush the function from the  
 ;;; Component-Lambdas.  We set Component-Reanalyze to true to indicate that the  
 ;;; DFO should be recomputed.  
 ;;;  
 ;;;    If the lambda is is a different component than the call, then we call  
 ;;; JOIN-COMPONENTS.  This only happens before the FIND-INITIAL-DFO in block  
 ;;; compilation.  
 ;;;  
 (defun insert-let-body (fun call)  
   (declare (type clambda fun) (type basic-combination call))  
   (setf (lambda-call-lexenv fun) (node-lexenv call))  
   (let* ((call-block (node-block call))  
          (bind-block (node-block (lambda-bind fun)))  
          (component (block-component call-block)))  
     (let ((fun-component (block-component bind-block)))  
       (unless (eq fun-component component)  
         (assert (eq (component-kind component) :initial))  
         (join-components component fun-component)))  
   
     (let ((*current-component* component))  
       (node-ends-block call))  
     (setf (component-lambdas component)  
           (delete fun (component-lambdas component)))  
     (assert (= (length (block-succ call-block)) 1))  
     (let ((next-block (first (block-succ call-block))))  
       (unlink-blocks call-block next-block)  
       (unlink-blocks (component-head component) bind-block)  
       (link-blocks call-block bind-block)  
       (let ((return (lambda-return fun)))  
         (when return  
           (let ((return-block (node-block return)))  
             (unlink-blocks return-block (component-tail component))  
             (link-blocks return-block next-block)))))  
     (setf (component-reanalyze component) t))  
   (undefined-value))  
   
   
647  ;;; Move-Return-Uses  --  Internal  ;;; Move-Return-Uses  --  Internal
648  ;;;  ;;;
649  ;;;    Handle the value semantics of let conversion.  When Fun has a return  ;;;    Handle the value semantics of let conversion.  Delete Fun's return node,
650  ;;; node, we delete it and move all the uses of the result continuation to  ;;; and change the control flow to transfer to Next-Block instead.  Move all
651  ;;; Call's Cont.  ;;; the uses of the result continuation to Call's Cont.
652  ;;;  ;;;
653  ;;;    If the actual continuation is only used by the let call, then we  ;;;    If the actual continuation is only used by the let call, then we
654  ;;; intersect the type assertion on the dummy continuation with the assertion  ;;; intersect the type assertion on the dummy continuation with the assertion
# Line 659  Line 659 
659  ;;; all the dummy continuation's uses.  This serves mainly to propagate  ;;; all the dummy continuation's uses.  This serves mainly to propagate
660  ;;; TRULY-THE through lets.  ;;; TRULY-THE through lets.
661  ;;;  ;;;
662  (defun move-return-uses (fun call)  (defun move-return-uses (fun call next-block)
663    (declare (type clambda fun) (type basic-combination call))    (declare (type clambda fun) (type basic-combination call)
664    (let ((return (lambda-return fun)))             (type cblock next-block))
665      (when return    (let* ((return (lambda-return fun))
666        (unlink-node return)           (return-block (node-block return)))
667        (delete-return return)      (unlink-blocks return-block
668                       (component-tail (block-component return-block)))
669        (link-blocks return-block next-block)
670        (unlink-node return)
671        (delete-return return)
672        (let ((result (return-result return))
673              (cont (node-cont call))
674              (call-type (node-derived-type call)))
675          (when (eq (continuation-use cont) call)
676            (assert-continuation-type cont (continuation-asserted-type result)))
677          (unless (eq call-type *wild-type*)
678            (do-uses (use result)
679              (derive-node-type use call-type)))
680          (substitute-continuation-uses cont result)))
681      (undefined-value))
682    
683    
684    
685    ;;; MOVE-LET-CALL-CONT  --  Internal
686    ;;;
687    ;;;    Change all Cont for all the calls to Fun to be the start continuation
688    ;;; for the bind node.  This allows the blocks to be joined if the caller count
689    ;;; ever goes to one.
690    ;;;
691    (defun move-let-call-cont (fun)
692      (declare (type clambda fun))
693      (let ((new-cont (node-prev (lambda-bind fun))))
694        (dolist (ref (leaf-refs fun))
695          (let ((dest (continuation-dest (node-cont ref))))
696            (delete-continuation-use dest)
697            (add-continuation-use dest new-cont))))
698      (undefined-value))
699    
       (let ((result (return-result return))  
             (cont (node-cont call))  
             (call-type (node-derived-type call)))  
         (when (eq (continuation-use cont) call)  
           (assert-continuation-type cont (continuation-asserted-type result)))  
         (unless (eq call-type *wild-type*)  
           (do-uses (use result)  
             (derive-node-type use call-type)))  
   
         (delete-continuation-use call)  
         (add-continuation-use call (node-prev (lambda-bind fun)))  
         (substitute-continuation-uses cont result))))  
700    
701    ;;; MOVE-RETURN-STUFF  --  Internal
702    ;;;
703    ;;;    Deal with returning from a let or assignment that we are converting.
704    ;;; FUN is the function we are calling, CALL is a call to FUN, and NEXT-BLOCK
705    ;;; is the return point for a non-tail call, or NULL if call is a tail call.
706    ;;;
707    ;;; We do different things depending on whether the caller and callee have
708    ;;; returns left:
709    ;;; -- If the callee has no return, it doesn't return, so we just do
710    ;;;    MOVE-LET-CALL-CONT.
711    ;;; -- If CALL is a non-tail call, or if both have returns, then we
712    ;;;    delete the callee's return, move its uses to the call's result
713    ;;;    continuation, and transfer control to the appropriate return point.
714    ;;; -- If the callee has a return, but the caller doesn't, then we move the
715    ;;;    return to the caller.  [Note: here CALL is always TR.]
716    ;;;
717    (defun move-return-stuff (fun call next-block)
718      (declare (type clambda fun) (type basic-combination call)
719               (type (or cblock null) next-block))
720      (let* ((return (lambda-return fun))
721             (call-fun (node-home-lambda call))
722             (call-return (lambda-return call-fun)))
723        (when return
724          (cond ((or next-block call-return)
725                 (unless (block-delete-p (node-block return))
726                   (move-return-uses fun call
727                                     (or next-block (node-block call-return)))))
728                (t
729                 (setf (lambda-return call-fun) return)
730                 (setf (return-lambda return) call-fun))))
731        (move-let-call-cont fun))
732    (undefined-value))    (undefined-value))
733    
734    
# Line 693  Line 743 
743  ;;;  ;;;
744  (defun let-convert (fun call)  (defun let-convert (fun call)
745    (declare (type clambda fun) (type basic-combination call))    (declare (type clambda fun) (type basic-combination call))
746    (insert-let-body fun call)    (let ((next-block (if (node-tail-p call)
747    (merge-lets fun call)                          nil
748    (move-return-uses fun call)                          (insert-let-body fun call))))
749        (merge-lets fun call)
750        (move-return-stuff fun call next-block))
751    
752    (maybe-remove-free-function fun)    (maybe-remove-free-function fun)
753    (dolist (arg (basic-combination-args call))    (dolist (arg (basic-combination-args call))
754      (when arg      (when arg
# Line 711  Line 764 
764  ;;; call analysis, and also when a reference is deleted.  We only convert to a  ;;; call analysis, and also when a reference is deleted.  We only convert to a
765  ;;; let when the function is a normal local function, has no XEP, and is  ;;; let when the function is a normal local function, has no XEP, and is
766  ;;; referenced in exactly one local call.  Conversion is also inhibited if the  ;;; referenced in exactly one local call.  Conversion is also inhibited if the
767  ;;; only reference is in a block about to be deleted.  ;;; only reference is in a block about to be deleted.  We return true if we
768    ;;; converted.
769  ;;;  ;;;
770  ;;;    These rules may seem unnecessarily restrictive, since there are some  ;;;    These rules may seem unnecessarily restrictive, since there are some
771  ;;; cases where we could do the return with a jump that don't satisfy these  ;;; cases where we could do the return with a jump that don't satisfy these
772  ;;; requirements.  The reason for doing things this way is that it makes the  ;;; requirements.  The reason for doing things this way is that it makes the
773  ;;; concept of a let much more useful at the level of IR1 semantics.  Low-level  ;;; concept of a let much more useful at the level of IR1 semantics.  The
774  ;;; control and environment optimizations can always be done later on.  ;;; :ASSIGNMENT function kind provides another way to optimize calls to
775    ;;; single-return/multiple call functions.
776  ;;;  ;;;
777  ;;;    We don't attempt to convert calls to functions that have an XEP, since  ;;;    We don't attempt to convert calls to functions that have an XEP, since
778  ;;; we might be embarrassed later when we want to convert a newly discovered  ;;; we might be embarrassed later when we want to convert a newly discovered
# Line 728  Line 783 
783    (let ((refs (leaf-refs fun)))    (let ((refs (leaf-refs fun)))
784      (when (and refs (null (rest refs))      (when (and refs (null (rest refs))
785                 (not (block-delete-p (node-block (first refs))))                 (not (block-delete-p (node-block (first refs))))
786                 (not (functional-kind fun))                 (member (functional-kind fun) '(nil :assignment))
787                 (not (functional-entry-function fun)))                 (not (functional-entry-function fun)))
788        (let* ((ref-cont (node-cont (first refs)))        (let* ((ref-cont (node-cont (first refs)))
789               (dest (continuation-dest ref-cont)))               (dest (continuation-dest ref-cont)))
# Line 737  Line 792 
792                     (eq (basic-combination-kind dest) :local))                     (eq (basic-combination-kind dest) :local))
793            (let-convert fun dest)            (let-convert fun dest)
794            (setf (functional-kind fun)            (setf (functional-kind fun)
795                  (if (mv-combination-p dest) :mv-let :let))))))                  (if (mv-combination-p dest) :mv-let :let))))
796    (undefined-value))        t)))
797    
798    
799    ;;;; Tail local calls and assignments:
800    
801    ;;; ONLY-HARMLESS-CLEANUPS  --  Internal
802    ;;;
803    ;;;    Return T if there are no cleanups between Block1 and Block2, or if they
804    ;;; definitely won't generate any cleanup code.  Currently we recognize lexical
805    ;;; entry points that are only used locally (if at all).
806    ;;;
807    (defun only-harmless-cleanups (block1 block2)
808      (declare (type cblock block1 block2))
809      (or (eq block1 block2)
810          (let ((cleanup2 (block-start-cleanup block2)))
811            (do ((cleanup (block-end-cleanup block1)
812                          (node-enclosing-cleanup (cleanup-mess-up cleanup))))
813                ((eq cleanup cleanup2) t)
814              (case (cleanup-kind cleanup)
815                ((:block :tagbody)
816                 (unless (null (entry-exits (cleanup-mess-up cleanup)))
817                   (return nil)))
818                (t (return nil)))))))
819    
820    
821    ;;; MAYBE-CONVERT-TAIL-LOCAL-CALL  --  Interface
822    ;;;
823    ;;;    If possible, convert a tail-local call to jump directly to the called
824    ;;; function.  We also call MAYBE-CONVERT-TO-ASSIGNMENT.  We can switch the
825    ;;; succesor (potentially deleting the RETURN node) unless:
826    ;;; -- The call is in an XEP (thus we might decide to make it non-tail so that
827    ;;;    we can use known return inside the component.)
828    ;;; -- There is a change in the cleanup between the call in the return, so we
829    ;;;    might need to introduce cleanup code.
830    ;;;
831    (defun maybe-convert-tail-local-call (call)
832      (declare (type combination call))
833      (let ((return (continuation-dest (node-cont call))))
834        (assert (return-p return))
835        (when (and (not (node-tail-p call))
836                   (not (eq (functional-kind (node-home-lambda call))
837                            :external))
838                   (only-harmless-cleanups (node-block call)
839                                           (node-block return)))
840          (node-ends-block call)
841          (let ((block (node-block call))
842                (fun (combination-lambda call)))
843            (setf (node-tail-p call) t)
844            (unlink-blocks block (first (block-succ block)))
845            (link-blocks block (node-block (lambda-bind fun)))
846            (values t (maybe-convert-to-assignment fun))))))
847    
848    
849    ;;; MAYBE-CONVERT-TO-ASSIGNMENT  --  Interface
850    ;;;
851    ;;;    Called when we believe it might make sense to convert Fun to an
852    ;;; assignment.  We can convert when:
853    ;;; -- The function is a normal, non-entry function, and
854    ;;; -- There is at most one non-tail call (which must not be recursive), and
855    ;;; -- All calls are self-recursive or appear in at most one other function (so
856    ;;;    we can be sure that we can merge all the code into a single
857    ;;;    environment.)
858    ;;;
859    ;;; If there is one non-tail call, then we convert exactly like a let.  If
860    ;;; there are no non-tail calls, then we merge the environments and deal with
861    ;;; the return.
862    ;;;
863    (defun maybe-convert-to-assignment (fun)
864      (declare (type clambda fun))
865      (when (and (not (functional-kind fun))
866                 (not (functional-entry-function fun)))
867        (let ((non-tail nil)
868              (call-fun nil))
869          (when (dolist (ref (leaf-refs fun) t)
870                  (let ((dest (continuation-dest (node-cont ref))))
871                    (when (block-delete-p (node-block dest)) (return nil))
872                    (let ((home (node-home-lambda ref)))
873                      (unless (eq home fun)
874                        (when call-fun (return nil))
875                        (setq call-fun home))
876                      (unless (node-tail-p dest)
877                        (when (or non-tail (eq home fun)) (return nil))
878                        (setq non-tail dest)))))
879            (let-convert fun (or non-tail
880                                 (continuation-dest
881                                  (node-cont (first (leaf-refs fun))))))
882            (setf (functional-kind fun) :assignment)
883            t))))

Legend:
Removed from v.1.22  
changed lines
  Added in v.1.23

  ViewVC Help
Powered by ViewVC 1.1.5