X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1opt.lisp;h=616c984464fb3e83221cee6ec36b92f114c7f0f7;hb=0cfad881b88e03971a2b3ef0c0c0fc2e5f4f1bc8;hp=25b0b69e8702027d735ec0b86bd39afd98ce300a;hpb=204f2fa9771ad9e55718dc76205afec7d11b3011;p=sbcl.git diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 25b0b69..616c984 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -18,12 +18,13 @@ ;;;; interface for obtaining results of constant folding -;;; Return true if the sole use of Cont is a reference to a constant leaf. -(declaim (ftype (function (continuation) boolean) constant-continuation-p)) -(defun constant-continuation-p (cont) - (let ((use (continuation-use cont))) - (and (ref-p use) - (constant-p (ref-leaf use))))) +;;; Return true for a CONTINUATION whose sole use is a reference to a +;;; constant leaf. +(defun constant-continuation-p (thing) + (and (continuation-p thing) + (let ((use (continuation-use thing))) + (and (ref-p use) + (constant-p (ref-leaf use)))))) ;;; Return the constant value for a continuation whose only use is a ;;; constant node. @@ -166,10 +167,10 @@ (reoptimize-continuation (node-cont node)))))) (values)) -;;; Similar to Derive-Node-Type, but asserts that it is an error for -;;; Cont's value not to be typep to Type. If we improve the assertion, -;;; we set TYPE-CHECK and TYPE-ASSERTED to guarantee that the new -;;; assertion will be checked. +;;; This is similar to DERIVE-NODE-TYPE, but asserts that it is an +;;; error for CONT's value not to be TYPEP to TYPE. If we improve the +;;; assertion, we set TYPE-CHECK and TYPE-ASSERTED to guarantee that +;;; the new assertion will be checked. (defun assert-continuation-type (cont type) (declare (type continuation cont) (type ctype type)) (let ((cont-type (continuation-asserted-type cont))) @@ -184,28 +185,28 @@ (reoptimize-continuation cont))))) (values)) -;;; Assert that Call is to a function of the specified Type. It is +;;; Assert that CALL is to a function of the specified TYPE. It is ;;; assumed that the call is legal and has only constants in the ;;; keyword positions. (defun assert-call-type (call type) - (declare (type combination call) (type function-type type)) - (derive-node-type call (function-type-returns type)) + (declare (type combination call) (type fun-type type)) + (derive-node-type call (fun-type-returns type)) (let ((args (combination-args call))) - (dolist (req (function-type-required type)) + (dolist (req (fun-type-required type)) (when (null args) (return-from assert-call-type)) (let ((arg (pop args))) (assert-continuation-type arg req))) - (dolist (opt (function-type-optional type)) + (dolist (opt (fun-type-optional type)) (when (null args) (return-from assert-call-type)) (let ((arg (pop args))) (assert-continuation-type arg opt))) - (let ((rest (function-type-rest type))) + (let ((rest (fun-type-rest type))) (when rest (dolist (arg args) (assert-continuation-type arg rest)))) - (dolist (key (function-type-keywords type)) + (dolist (key (fun-type-keywords type)) (let ((name (key-info-name key))) (do ((arg args (cddr arg))) ((null arg)) @@ -216,9 +217,9 @@ ;;;; IR1-OPTIMIZE -;;; Do one forward pass over Component, deleting unreachable blocks +;;; Do one forward pass over COMPONENT, deleting unreachable blocks ;;; and doing IR1 optimizations. We can ignore all blocks that don't -;;; have the Reoptimize flag set. If Component-Reoptimize is true when +;;; have the REOPTIMIZE flag set. If COMPONENT-REOPTIMIZE is true when ;;; we are done, then another iteration would be beneficial. ;;; ;;; We delete blocks when there is either no predecessor or the block @@ -310,10 +311,10 @@ ;;; 1. The successor has more than one predecessor. ;;; 2. The last node's CONT is also used somewhere else. ;;; 3. The successor is the current block (infinite loop). -;;; 4. The next block has a different cleanup, and thus we may want to -;;; insert cleanup code between the two blocks at some point. -;;; 5. The next block has a different home lambda, and thus the control -;;; transfer is a non-local exit. +;;; 4. The next block has a different cleanup, and thus we may want +;;; to insert cleanup code between the two blocks at some point. +;;; 5. The next block has a different home lambda, and thus the +;;; control transfer is a non-local exit. ;;; ;;; If we succeed, we return true, otherwise false. ;;; @@ -604,14 +605,16 @@ ;;; This function attempts to delete an exit node, returning true if ;;; it deletes the block as a consequence: -;;; -- If the exit is degenerate (has no Entry), then we don't do anything, -;;; since there is nothing to be done. -;;; -- If the exit node and its Entry have the same home lambda then we know -;;; the exit is local, and can delete the exit. We change uses of the -;;; Exit-Value to be uses of the original continuation, then unlink the -;;; node. If the exit is to a TR context, then we must do MERGE-TAIL-SETS -;;; on any local calls which delivered their value to this exit. -;;; -- If there is no value (as in a GO), then we skip the value semantics. +;;; -- If the exit is degenerate (has no Entry), then we don't do +;;; anything, since there is nothing to be done. +;;; -- If the exit node and its Entry have the same home lambda then +;;; we know the exit is local, and can delete the exit. We change +;;; uses of the Exit-Value to be uses of the original continuation, +;;; then unlink the node. If the exit is to a TR context, then we +;;; must do MERGE-TAIL-SETS on any local calls which delivered +;;; their value to this exit. +;;; -- If there is no value (as in a GO), then we skip the value +;;; semantics. ;;; ;;; This function is also called by environment analysis, since it ;;; wants all exits to be optimized even if normal optimization was @@ -684,8 +687,8 @@ ;; cross-compiler doesn't know how to evaluate it. #+sb-xc-host (let* ((ref (continuation-use (combination-fun node))) - (fun (leaf-name (ref-leaf ref)))) - (fboundp fun))) + (fun-name (leaf-source-name (ref-leaf ref)))) + (fboundp fun-name))) (constant-fold-call node) (return-from ir1-optimize-combination))) @@ -702,7 +705,7 @@ #!+sb-show (when *show-transforms-p* (let* ((cont (basic-combination-fun node)) - (fname (continuation-function-name cont t))) + (fname (continuation-fun-name cont t))) (/show "trying transform" x (transform-function x) "for" fname))) (unless (ir1-transform node x) #!+sb-show @@ -732,8 +735,7 @@ (tail (component-tail (block-component block))) (succ (first (block-succ block)))) (unless (or (and (eq call (block-last block)) (eq succ tail)) - (block-delete-p block) - *converting-for-interpreter*) + (block-delete-p block)) (when (or (and (eq (continuation-asserted-type cont) *empty-type*) (not (or ir1-p (eq (continuation-kind cont) :deleted)))) (eq (node-derived-type call) *empty-type*)) @@ -763,30 +765,31 @@ ;;; This is called both by IR1 conversion and IR1 optimization when ;;; they have verified the type signature for the call, and are ;;; wondering if something should be done to special-case the call. If -;;; Call is a call to a global function, then see whether it defined +;;; CALL is a call to a global function, then see whether it defined ;;; or known: -;;; -- If a DEFINED-FUNCTION should be inline expanded, then convert the -;;; expansion and change the call to call it. Expansion is enabled if -;;; :INLINE or if space=0. If the FUNCTIONAL slot is true, we never expand, -;;; since this function has already been converted. Local call analysis -;;; will duplicate the definition if necessary. We claim that the parent -;;; form is LABELS for context declarations, since we don't want it to be -;;; considered a real global function. -;;; -- In addition to a direct check for the function name in the table, we -;;; also must check for slot accessors. If the function is a slot accessor, -;;; then we set the combination kind to the function info of %Slot-Setter or -;;; %Slot-Accessor, as appropriate. -;;; -- If it is a known function, mark it as such by setting the Kind. +;;; -- If a DEFINED-FUN should be inline expanded, then convert +;;; the expansion and change the call to call it. Expansion is +;;; enabled if :INLINE or if SPACE=0. If the FUNCTIONAL slot is +;;; true, we never expand, since this function has already been +;;; converted. Local call analysis will duplicate the definition if +;;; necessary. We claim that the parent form is LABELS for context +;;; declarations, since we don't want it to be considered a real +;;; global function. +;;; -- In addition to a direct check for the function name in the +;;; table, we also must check for slot accessors. If the function +;;; is a slot accessor, then we set the combination kind to the +;;; function info of %Slot-Setter or %Slot-Accessor, as +;;; appropriate. +;;; -- If it is a known function, mark it as such by setting the KIND. ;;; ;;; We return the leaf referenced (NIL if not a leaf) and the -;;; function-info assigned. +;;; FUNCTION-INFO assigned. (defun recognize-known-call (call ir1-p) (declare (type combination call)) (let* ((ref (continuation-use (basic-combination-fun call))) (leaf (when (ref-p ref) (ref-leaf ref))) - (inlinep (if (and (defined-function-p leaf) - (not (byte-compiling))) - (defined-function-inlinep leaf) + (inlinep (if (defined-fun-p leaf) + (defined-fun-inlinep leaf) :no-chance))) (cond ((eq inlinep :notinline) (values nil nil)) @@ -797,34 +800,38 @@ (:inline t) (:no-chance nil) ((nil :maybe-inline) (policy call (zerop space)))) - (defined-function-inline-expansion leaf) - (let ((fun (defined-function-functional leaf))) + ;; FIXME: In sbcl-0.pre7.87, it looks as though we'll + ;; get here when LEAF is a GLOBAL-VAR (not a DEFINED-FUN) + ;; whenever (ZEROP SPACE), in which case we'll die with + ;; a type error when we try to access LEAF as a DEFINED-FUN. + (defined-fun-inline-expansion leaf) + (let ((fun (defined-fun-functional leaf))) (or (not fun) (and (eq inlinep :inline) (functional-kind fun)))) (inline-expansion-ok call)) (flet ((frob () (let ((res (ir1-convert-lambda-for-defun - (defined-function-inline-expansion leaf) + (defined-fun-inline-expansion leaf) leaf t #'ir1-convert-inline-lambda))) - (setf (defined-function-functional leaf) res) + (setf (defined-fun-functional leaf) res) (change-ref-leaf ref res)))) (if ir1-p (frob) (with-ir1-environment call (frob) - (local-call-analyze *current-component*)))) + (locall-analyze-component *current-component*)))) (values (ref-leaf (continuation-use (basic-combination-fun call))) nil)) (t - (let* ((name (leaf-name leaf)) + (let* ((name (leaf-source-name leaf)) (info (info :function :info (if (slot-accessor-p leaf) - (if (consp name) - '%slot-setter - '%slot-accessor) - name)))) + (if (consp source-name) ; i.e. if SETF function + '%slot-setter + '%slot-accessor) + name)))) (if info (values leaf (setf (basic-combination-kind call) info)) (values leaf nil))))))) @@ -838,7 +845,7 @@ ;;; and that checking is done by local call analysis. (defun validate-call-type (call type ir1-p) (declare (type combination call) (type ctype type)) - (cond ((not (function-type-p type)) + (cond ((not (fun-type-p type)) (aver (multiple-value-bind (val win) (csubtypep type (specifier-type 'function)) (or val (not win)))) @@ -872,7 +879,7 @@ (values nil nil)))) ;;; This is called by IR1-OPTIMIZE when the function for a call has -;;; changed. If the call is local, we try to let-convert it, and +;;; changed. If the call is local, we try to LET-convert it, and ;;; derive the result type. If it is a :FULL call, we validate it ;;; against the type, which recognizes known calls, does inline ;;; expansion, etc. If a call to a predicate in a non-conditional @@ -897,29 +904,40 @@ (continuation-use (basic-combination-fun call)) call)) ((not leaf)) - ((or (info :function :source-transform (leaf-name leaf)) + ((or (info :function :source-transform (leaf-source-name leaf)) (and info (ir1-attributep (function-info-attributes info) predicate) (let ((dest (continuation-dest (node-cont call)))) (and dest (not (if-p dest)))))) - (let ((name (leaf-name leaf))) - (when (symbolp name) - (let ((dums (make-gensym-list (length - (combination-args call))))) - (transform-call call - `(lambda ,dums - (,name ,@dums)))))))))))) + (when (and (leaf-has-source-name-p leaf) + ;; FIXME: This SYMBOLP is part of a literal + ;; translation of a test in the old CMU CL + ;; source, and it's not quite clear what + ;; the old source meant. Did it mean "has a + ;; valid name"? Or did it mean "is an + ;; ordinary function name, not a SETF + ;; function"? Either way, the old CMU CL + ;; code probably didn't deal with SETF + ;; functions correctly, and neither does + ;; this new SBCL code, and that should be fixed. + (symbolp (leaf-source-name leaf))) + (let ((dummies (make-gensym-list (length + (combination-args call))))) + (transform-call call + `(lambda ,dummies + (,(leaf-source-name leaf) + ,@dummies))))))))))) (values)) ;;;; known function optimization -;;; Add a failed optimization note to FAILED-OPTIMZATIONS for Node, -;;; Fun and Args. If there is already a note for Node and Transform, +;;; Add a failed optimization note to FAILED-OPTIMZATIONS for NODE, +;;; FUN and ARGS. If there is already a note for NODE and TRANSFORM, ;;; replace it, otherwise add a new one. (defun record-optimization-failure (node transform args) (declare (type combination node) (type transform transform) - (type (or function-type list) args)) + (type (or fun-type list) args)) (let* ((table (component-failed-optimizations *component-being-compiled*)) (found (assoc transform (gethash node table)))) (if found @@ -938,16 +956,14 @@ (declare (type combination node) (type transform transform)) (let* ((type (transform-type transform)) (fun (transform-function transform)) - (constrained (function-type-p type)) + (constrained (fun-type-p type)) (table (component-failed-optimizations *component-being-compiled*)) (flame (if (transform-important transform) (policy node (>= speed inhibit-warnings)) (policy node (> speed inhibit-warnings)))) (*compiler-error-context* node)) (cond ((not (member (transform-when transform) - (if *byte-compiling* - '(:byte :both) - '(:native :both)))) + '(:native :both))) ;; FIXME: Make sure that there's a transform for ;; (MEMBER SYMBOL ..) into MEMQ. ;; FIXME: Note that when/if I make SHARE operation to shared @@ -957,7 +973,7 @@ ;; '(:BOTH) tail sublists. (let ((when (transform-when transform))) (not (or (eq when :both) - (eq when (if *byte-compiling* :byte :native))))) + (eq when :native)))) t) ((or (not constrained) (valid-function-use node type :strict-result t)) @@ -1068,17 +1084,19 @@ (defun transform-call (node res) (declare (type combination node) (list res)) (with-ir1-environment node - (let ((new-fun (ir1-convert-inline-lambda res)) + (let ((new-fun (ir1-convert-inline-lambda + res + :debug-name "")) (ref (continuation-use (combination-fun node)))) (change-ref-leaf ref new-fun) (setf (combination-kind node) :full) - (local-call-analyze *current-component*))) + (locall-analyze-component *current-component*))) (values)) ;;; Replace a call to a foldable function of constant arguments with ;;; the result of evaluating the form. We insert the resulting ;;; constant node after the call, stealing the call's continuation. We -;;; give the call a continuation with no Dest, which should cause it +;;; give the call a continuation with no DEST, which should cause it ;;; and its arguments to go away. If there is an error during the ;;; evaluation, we give a warning and leave the call alone, making the ;;; call a :ERROR call. @@ -1089,10 +1107,10 @@ (declare (type combination call)) (let* ((args (mapcar #'continuation-value (combination-args call))) (ref (continuation-use (combination-fun call))) - (fun (leaf-name (ref-leaf ref)))) + (fun-name (leaf-source-name (ref-leaf ref)))) (multiple-value-bind (values win) - (careful-call fun args call "constant folding") + (careful-call fun-name args call "constant folding") (if (not win) (setf (combination-kind call) :error) (let ((dummies (make-gensym-list (length args)))) @@ -1106,14 +1124,14 @@ ;;;; local call optimization -;;; Propagate Type to Leaf and its Refs, marking things changed. If +;;; Propagate TYPE to LEAF and its REFS, marking things changed. If ;;; the leaf type is a function type, then just leave it alone, since ;;; TYPE is never going to be more specific than that (and ;;; TYPE-INTERSECTION would choke.) (defun propagate-to-refs (leaf type) (declare (type leaf leaf) (type ctype type)) (let ((var-type (leaf-type leaf))) - (unless (function-type-p var-type) + (unless (fun-type-p var-type) (let ((int (type-approx-intersection2 var-type type))) (when (type/= int var-type) (setf (leaf-type leaf) int) @@ -1157,12 +1175,11 @@ ((or constant functional) t) (lambda-var (null (lambda-var-sets leaf))) - (defined-function - (not (eq (defined-function-inlinep leaf) :notinline))) + (defined-fun + (not (eq (defined-fun-inlinep leaf) :notinline))) (global-var (case (global-var-kind leaf) - (:global-function t) - (:constant t)))))) + (:global-function t)))))) ;;; If we have a non-set LET var with a single use, then (if possible) ;;; replace the variable reference's CONT with the arg continuation. @@ -1175,7 +1192,7 @@ ;;; would be NIL. ;;; -- the var's DEST has a different policy than the ARG's (think safety). ;;; -;;; We change the Ref to be a reference to NIL with unused value, and +;;; We change the REF to be a reference to NIL with unused value, and ;;; let it be flushed as dead code. A side-effect of this substitution ;;; is to delete the variable. (defun substitute-single-use-continuation (arg var) @@ -1234,7 +1251,7 @@ ;;; ;;; Substitution of individual references is inhibited if the ;;; reference is in a different component from the home. This can only -;;; happen with closures over top-level lambda vars. In such cases, +;;; happen with closures over top level lambda vars. In such cases, ;;; the references may have already been compiled, and thus can't be ;;; retroactively modified. ;;; @@ -1267,12 +1284,11 @@ t) (t (aver (eq (functional-kind (lambda-home fun)) - :top-level)) + :toplevel)) nil))) leaf var)) t))))) ((and (null (rest (leaf-refs var))) - (not *byte-compiling*) (substitute-single-use-continuation arg var))) (t (propagate-to-refs var (continuation-type arg)))))) @@ -1363,8 +1379,8 @@ (when fun-changed (setf (continuation-reoptimize fun) nil) (let ((type (continuation-type fun))) - (when (function-type-p type) - (derive-node-type node (function-type-returns type)))) + (when (fun-type-p type) + (derive-node-type node (fun-type-returns type)))) (maybe-terminate-block node nil) (let ((use (continuation-use fun))) (when (and (ref-p use) (functional-p (ref-leaf use))) @@ -1372,7 +1388,7 @@ (when (eq (basic-combination-kind node) :local) (maybe-let-convert (ref-leaf use)))))) (unless (or (eq (basic-combination-kind node) :local) - (eq (continuation-function-name fun) '%throw)) + (eq (continuation-fun-name fun) '%throw)) (ir1-optimize-mv-call node)) (dolist (arg args) (setf (continuation-reoptimize arg) nil)))) @@ -1437,7 +1453,7 @@ (return-from ir1-optimize-mv-call)) (multiple-value-bind (min max) - (function-type-nargs (continuation-type fun)) + (fun-type-nargs (continuation-type fun)) (let ((total-nvals (multiple-value-bind (types nvals) (values-types (continuation-derived-type (first args))) @@ -1475,7 +1491,7 @@ (funcall ,(ref-leaf ref) ,@dums))))) (change-ref-leaf ref fun) (aver (eq (basic-combination-kind node) :full)) - (local-call-analyze *current-component*) + (locall-analyze-component *current-component*) (aver (eq (basic-combination-kind node) :local))))))))) (values)) @@ -1499,7 +1515,7 @@ (let* ((arg (first (basic-combination-args call))) (use (continuation-use arg))) (when (and (combination-p use) - (eq (continuation-function-name (combination-fun use)) + (eq (continuation-fun-name (combination-fun use)) 'values)) (let* ((fun (combination-lambda call)) (vars (lambda-vars fun)) @@ -1549,7 +1565,7 @@ (defoptimizer (values-list optimizer) ((list) node) (let ((use (continuation-use list))) (when (and (combination-p use) - (eq (continuation-function-name (combination-fun use)) + (eq (continuation-fun-name (combination-fun use)) 'list)) (change-ref-leaf (continuation-use (combination-fun node)) (find-free-function 'values "in a strange place"))