From f87f3f2b77b86b7d1e3dce9eb74092f7f1bdf036 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Mon, 7 Sep 1992 15:59:22 +0000 Subject: [PATCH] Added EXT:*INLINE-EXPANSION-LIMIT* and INLINE-EXPANSION-OK. Added some block compilation & inline expansion declarations, rearranged stuff for more locality. MAYBE-REMOVE-FREE-FUNCTION is history. --- compiler/ir1util.lisp | 392 ++++++++++++++++++++++++------------------ 1 file changed, 229 insertions(+), 163 deletions(-) diff --git a/compiler/ir1util.lisp b/compiler/ir1util.lisp index 66c7308e1..2b90d8420 100644 --- a/compiler/ir1util.lisp +++ b/compiler/ir1util.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.57 1992/08/03 12:32:11 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1util.lisp,v 1.58 1992/09/07 15:59:22 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -21,7 +21,8 @@ (in-package "EXTENSIONS") (export '(*error-print-level* *error-print-length* *error-print-lines* def-source-context *undefined-warning-limit* - *enclosing-source-cutoff*)) + *enclosing-source-cutoff* *inline-expansion-limit*)) + (in-package "C") @@ -190,6 +191,57 @@ (setf (continuation-dest new) dest)) (undefined-value)) +;;; Substitute-Continuation-Uses -- Interface +;;; +;;; Replace all uses of Old with uses of New, where New has an arbitary +;;; number of uses. If New will end up with more than one use, then we must +;;; arrange for it to start a block if it doesn't already. +;;; +(defun substitute-continuation-uses (new old) + (declare (type continuation old new)) + (unless (and (eq (continuation-kind new) :unused) + (eq (continuation-kind old) :inside-block)) + (ensure-block-start new)) + + (do-uses (node old) + (delete-continuation-use node) + (add-continuation-use node new)) + + (reoptimize-continuation new) + (undefined-value)) + + +;;;; Block starting/creation: + +;;; Continuation-Starts-Block -- Interface +;;; +;;; Return the block that Continuation is the start of, making a block if +;;; necessary. This function is called by IR1 translators which may cause a +;;; continuation to be used more than once. Every continuation which may be +;;; used more than once must start a block by the time that anyone does a +;;; Use-Continuation on it. +;;; +;;; We also throw the block into the next/prev list for the +;;; *current-component* so that we keep track of which blocks we have made. +;;; +(defun continuation-starts-block (cont) + (declare (type continuation cont)) + (ecase (continuation-kind cont) + (:unused + (assert (not (continuation-block cont))) + (let* ((head (component-head *current-component*)) + (next (block-next head)) + (new-block (make-block cont))) + (setf (block-next new-block) next) + (setf (block-prev new-block) head) + (setf (block-prev next) new-block) + (setf (block-next head) new-block) + (setf (continuation-block cont) new-block) + (setf (continuation-use cont) nil) + (setf (continuation-kind cont) :block-start) + new-block)) + (:block-start + (continuation-block cont)))) ;;; Ensure-Block-Start -- Interface ;;; @@ -218,26 +270,6 @@ (node-ends-block (continuation-use cont)))))))) (undefined-value)) - -;;; Substitute-Continuation-Uses -- Interface -;;; -;;; Replace all uses of Old with uses of New, where New has an arbitary -;;; number of uses. If New will end up with more than one use, then we must -;;; arrange for it to start a block if it doesn't already. -;;; -(defun substitute-continuation-uses (new old) - (declare (type continuation old new)) - (unless (and (eq (continuation-kind new) :unused) - (eq (continuation-kind old) :inside-block)) - (ensure-block-start new)) - - (do-uses (node old) - (delete-continuation-use node) - (add-continuation-use node new)) - - (reoptimize-continuation new) - (undefined-value)) - ;;;; Misc shortand functions: @@ -318,8 +350,8 @@ ;;; TLF number last.) ;;; (defun source-path-original-source (path) - (declare (list path)) - (cddr (member 'original-source-start path))) + (declare (list path) (inline member)) + (cddr (member 'original-source-start path :test #'eq))) ;;; SOURCE-PATH-FORM-NUMBER -- Interface @@ -329,8 +361,8 @@ ;;; subforms of the top level source form. ;;; (defun source-path-form-number (path) - (declare (list path)) - (cadr (member 'original-source-start path))) + (declare (list path) (inline member)) + (cadr (member 'original-source-start path :test #'eq))) ;;; SOURCE-PATH-FORMS -- Interface @@ -376,7 +408,7 @@ ;;; (defun make-lexenv (&key (default *lexical-environment*) functions variables blocks tags type-restrictions - inlines options + options (lambda (lexenv-lambda default)) (cleanup (lexenv-cleanup default)) (cookie (lexenv-cookie default)) @@ -392,7 +424,6 @@ (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - (frob inlines lexenv-inlines) lambda cleanup cookie interface-cookie (frob options lexenv-options)))) @@ -421,12 +452,22 @@ ;;; ;;; Join Block1 and Block2. ;;; +(declaim (inline link-blocks)) (defun link-blocks (block1 block2) (declare (type cblock block1 block2)) - (assert (not (member block2 (block-succ block1)))) - (push block2 (block-succ block1)) + (setf (block-succ block1) + (if (block-succ block1) + (%link-blocks block1 block2) + (list block2))) (push block1 (block-pred block2)) (undefined-value)) +;;; +(defun %link-blocks (block1 block2) + (declare (type cblock block1 block2) (inline member)) + (let ((succ1 (block-succ block1))) + (assert (not (member block2 succ1 :test #'eq))) + (cons block2 succ1))) + ;;; UNLINK-BLOCKS -- Interface ;;; @@ -437,11 +478,16 @@ ;;; (defun unlink-blocks (block1 block2) (declare (type cblock block1 block2)) - (assert (member block2 (block-succ block1))) - (setf (block-succ block1) - (delete block2 (block-succ block1))) - - (let ((new-pred (delete block1 (block-pred block2)))) + (let ((succ1 (block-succ block1))) + (if (eq block2 (car succ1)) + (setf (block-succ block1) (cdr succ1)) + (do ((succ (cdr succ1) (cdr succ)) + (prev succ1 succ)) + ((eq (car succ) block2) + (setf (cdr prev) (cdr succ))) + (assert succ)))) + + (let ((new-pred (delq block1 (block-pred block2)))) (setf (block-pred block2) new-pred) (when (and new-pred (null (rest new-pred))) (let ((pred-block (first new-pred))) @@ -459,10 +505,10 @@ ;;; successor. ;;; (defun change-block-successor (block old new) - (declare (type cblock new old block)) + (declare (type cblock new old block) (inline member)) (unlink-blocks block old) (setf (component-reanalyze (block-component block)) t) - (unless (member new (block-succ block)) + (unless (member new (block-succ block) :test #'eq) (link-blocks block new)) (let ((last (block-last block))) @@ -483,6 +529,7 @@ ;;; Component. ;;; (proclaim '(function remove-from-dfo (cblock) void)) +(declaim (inline remove-from-dfo)) (defun remove-from-dfo (block) (let ((next (block-next block)) (prev (block-prev block))) @@ -495,6 +542,7 @@ ;;; Add Block to the next/prev chain following After. We also set the ;;; Component to be the same as for After. ;;; +(declaim (inline add-to-dfo)) (defun add-to-dfo (block after) (declare (type cblock block after)) (let ((next (block-next after)) @@ -586,6 +634,9 @@ ;;;; Deleting stuff: +(declaim (start-block delete-ref delete-functional flush-dest + delete-continuation delete-block)) + ;;; Delete-Lambda-Var -- Internal ;;; ;;; Deal with deleting the last (read) reference to a lambda-var. We @@ -655,22 +706,6 @@ (undefined-value)) -;;; MAYBE-REMOVE-FREE-FUNCTION -- Interface -;;; -;;; This function is called when we let convert a function or blow away an -;;; XEP, or otherwise do something that should prevent any new references to -;;; Fun (or its optional-dispatch) from being created. -;;; -(defun maybe-remove-free-function (fun) - (declare (type functional fun)) - (let* ((fun (etypecase fun - (clambda (or (lambda-optional-dispatch fun) fun)) - (optional-dispatch fun))) - (entry (gethash (leaf-name fun) *free-functions*))) - (when (eq entry fun) - (remhash (leaf-name fun) *free-functions*))) - (undefined-value)) - ;;; Delete-Lambda -- Internal ;;; ;;; Deal with deleting the last reference to a lambda. Since there is only @@ -753,7 +788,6 @@ ;;; (defun delete-optional-dispatch (leaf) (declare (type optional-dispatch leaf)) - (maybe-remove-free-function leaf) (let ((entry (functional-entry-function leaf))) (unless (and entry (leaf-refs entry)) (assert (or (not entry) (eq (functional-kind entry) :deleted))) @@ -821,35 +855,6 @@ (undefined-value)) -;;; Delete-Return -- Interface -;;; -;;; Do stuff to indicate that the return node Node is being deleted. We set -;;; the RETURN to NIL. -;;; -(defun delete-return (node) - (declare (type creturn node)) - (let ((fun (return-lambda node))) - (assert (lambda-return fun)) - (setf (lambda-return fun) nil)) - (undefined-value)) - - -;;; NOTE-UNREFERENCED-VARS -- Interface -;;; -;;; If any of the Vars in fun were never referenced and was not declared -;;; IGNORE, then complain. -;;; -(defun note-unreferenced-vars (fun) - (declare (type clambda fun)) - (dolist (var (lambda-vars fun)) - (unless (or (leaf-ever-used var) - (lambda-var-ignorep var)) - (let ((*compiler-error-context* (lambda-bind fun))) - (unless (policy *compiler-error-context* (= brevity 3)) - (compiler-warning "Variable ~S defined but never used." - (leaf-name var))) - (setf (leaf-ever-used var) t)))) - (undefined-value)) ;;; Flush-Dest -- Interface @@ -946,81 +951,6 @@ (undefined-value)) -(defvar *deletion-ignored-objects* '(t nil)) - -;;; PRESENT-IN-FORM -- Internal -;;; -;;; Return true if we can find Obj in Form, NIL otherwise. We bound our -;;; recursion so that we don't get lost in circular structures. We ignore the -;;; car of forms if they are a symbol (to prevent confusing function -;;; referencess with variables), and we also ignore anything inside ' or #'. -;;; -(defun present-in-form (obj form depth) - (declare (type (integer 0 20) depth)) - (cond ((= depth 20) nil) - ((eq obj form) t) - ((atom form) nil) - (t - (let ((first (car form)) - (depth (1+ depth))) - (if (member first '(quote function)) - nil - (or (and (not (symbolp first)) - (present-in-form obj first depth)) - (do ((l (cdr form) (cdr l)) - (n 0 (1+ n))) - ((or (atom l) (> n 100)) - nil) - (declare (fixnum n)) - (when (present-in-form obj (car l) depth) - (return t))))))))) - - -;;; NOTE-BLOCK-DELETION -- Internal -;;; -;;; This function is called on a block immediately before we delete it. We -;;; check to see if any of the code about to die appeared in the original -;;; source, and emit a note if so. -;;; -;;; If the block was in a lambda is now deleted, then we ignore the whole -;;; block, since this case is picked off in DELETE-LAMBDA. We also ignore the -;;; deletion of CRETURN nodes, since it is somewhat reasonable for a function -;;; to not return, and there is a different note for that case anyway. -;;; -;;; If the actual source is an atom, then we use a bunch of heuristics to -;;; guess whether this reference really appeared in the original source: -;;; -- If a symbol, it must be interned and not a keyword. -;;; -- It must not be an easily introduced constant (T or NIL, a fixnum or a -;;; character.) -;;; -- The atom must be "present" in the original source form, and present in -;;; all intervening actual source forms. -;;; -(defun note-block-deletion (block) - (let ((home (block-home-lambda block))) - (unless (eq (functional-kind home) :deleted) - (do-nodes (node cont block) - (let* ((path (node-source-path node)) - (first (first path))) - (when (or (eq first 'original-source-start) - (and (atom first) - (or (not (symbolp first)) - (let ((pkg (symbol-package first))) - (and pkg - (not (eq pkg (symbol-package :end)))))) - (not (member first *deletion-ignored-objects*)) - (not (typep first '(or fixnum character))) - (every #'(lambda (x) - (present-in-form first x 0)) - (source-path-forms path)) - (present-in-form first (find-original-source path) - 0))) - (unless (return-p node) - (let ((*compiler-error-context* node)) - (compiler-note "Deleting unreachable code."))) - (return)))))) - (undefined-value)) - - ;;; Delete-Block -- Interface ;;; ;;; This function does what is necessary to eliminate the code in it from @@ -1100,6 +1030,114 @@ (remove-from-dfo block) (undefined-value)) +(declaim (end-block)) + + +;;; Delete-Return -- Interface +;;; +;;; Do stuff to indicate that the return node Node is being deleted. We set +;;; the RETURN to NIL. +;;; +(defun delete-return (node) + (declare (type creturn node)) + (let ((fun (return-lambda node))) + (assert (lambda-return fun)) + (setf (lambda-return fun) nil)) + (undefined-value)) + + +;;; NOTE-UNREFERENCED-VARS -- Interface +;;; +;;; If any of the Vars in fun were never referenced and was not declared +;;; IGNORE, then complain. +;;; +(defun note-unreferenced-vars (fun) + (declare (type clambda fun)) + (dolist (var (lambda-vars fun)) + (unless (or (leaf-ever-used var) + (lambda-var-ignorep var)) + (let ((*compiler-error-context* (lambda-bind fun))) + (unless (policy *compiler-error-context* (= brevity 3)) + (compiler-warning "Variable ~S defined but never used." + (leaf-name var))) + (setf (leaf-ever-used var) t)))) + (undefined-value)) + + +(defvar *deletion-ignored-objects* '(t nil)) + +;;; PRESENT-IN-FORM -- Internal +;;; +;;; Return true if we can find Obj in Form, NIL otherwise. We bound our +;;; recursion so that we don't get lost in circular structures. We ignore the +;;; car of forms if they are a symbol (to prevent confusing function +;;; referencess with variables), and we also ignore anything inside ' or #'. +;;; +(defun present-in-form (obj form depth) + (declare (type (integer 0 20) depth)) + (cond ((= depth 20) nil) + ((eq obj form) t) + ((atom form) nil) + (t + (let ((first (car form)) + (depth (1+ depth))) + (if (member first '(quote function)) + nil + (or (and (not (symbolp first)) + (present-in-form obj first depth)) + (do ((l (cdr form) (cdr l)) + (n 0 (1+ n))) + ((or (atom l) (> n 100)) + nil) + (declare (fixnum n)) + (when (present-in-form obj (car l) depth) + (return t))))))))) + + +;;; NOTE-BLOCK-DELETION -- Internal +;;; +;;; This function is called on a block immediately before we delete it. We +;;; check to see if any of the code about to die appeared in the original +;;; source, and emit a note if so. +;;; +;;; If the block was in a lambda is now deleted, then we ignore the whole +;;; block, since this case is picked off in DELETE-LAMBDA. We also ignore the +;;; deletion of CRETURN nodes, since it is somewhat reasonable for a function +;;; to not return, and there is a different note for that case anyway. +;;; +;;; If the actual source is an atom, then we use a bunch of heuristics to +;;; guess whether this reference really appeared in the original source: +;;; -- If a symbol, it must be interned and not a keyword. +;;; -- It must not be an easily introduced constant (T or NIL, a fixnum or a +;;; character.) +;;; -- The atom must be "present" in the original source form, and present in +;;; all intervening actual source forms. +;;; +(defun note-block-deletion (block) + (let ((home (block-home-lambda block))) + (unless (eq (functional-kind home) :deleted) + (do-nodes (node cont block) + (let* ((path (node-source-path node)) + (first (first path))) + (when (or (eq first 'original-source-start) + (and (atom first) + (or (not (symbolp first)) + (let ((pkg (symbol-package first))) + (and pkg + (not (eq pkg (symbol-package :end)))))) + (not (member first *deletion-ignored-objects*)) + (not (typep first '(or fixnum character))) + (every #'(lambda (x) + (present-in-form first x 0)) + (source-path-forms path)) + (present-in-form first (find-original-source path) + 0))) + (unless (return-p node) + (let ((*compiler-error-context* node)) + (compiler-note "Deleting unreachable code."))) + (return)))))) + (undefined-value)) + ;;; Unlink-Node -- Interface ;;; @@ -1309,6 +1347,7 @@ ;;; object is not in *constants*, then we create a new constant Leaf and ;;; enter it. ;;; +(declaim (maybe-inline find-constant)) (defun find-constant (object) (or (gethash object *constants*) (setf (gethash object *constants*) @@ -1372,6 +1411,7 @@ ;;; Return true if function is an XEP. This is true of normal XEPs ;;; (:External kind) and top-level lambdas (:Top-Level kind.) ;;; +(declaim (inline external-entry-point-p)) (defun external-entry-point-p (fun) (declare (type functional fun)) (not (null (member (functional-kind fun) '(:external :top-level))))) @@ -1381,17 +1421,18 @@ ;;; ;;; If Cont's only use is a non-notinline global function reference, then ;;; return the referenced symbol, otherwise NIL. If Notinline-OK is true, then -;;; we don't care if the ref is notinline. +;;; we don't care if the leaf is notinline. ;;; (defun continuation-function-name (cont &optional notinline-ok) (declare (type continuation cont)) (let ((use (continuation-use cont))) - (if (and (ref-p use) - (or (not (eq (ref-inlinep use) :notinline)) - notinline-ok)) + (if (ref-p use) (let ((leaf (ref-leaf use))) (if (and (global-var-p leaf) - (eq (global-var-kind leaf) :global-function)) + (eq (global-var-kind leaf) :global-function) + (or (not (defined-function-p leaf)) + (not (eq (defined-function-inlinep leaf) :notinline)) + notinline-ok)) (leaf-name leaf) nil)) nil))) @@ -1422,11 +1463,36 @@ ;;; ;;; Return the LAMBDA that is called by the local Call. ;;; +(declaim (inline combination-lambda)) (defun combination-lambda (call) (declare (type basic-combination call)) (assert (eq (basic-combination-kind call) :local)) (ref-leaf (continuation-use (basic-combination-fun call)))) + +(defvar *inline-expansion-limit* 20 + "An upper limit on the number of inline function calls that will be expanded + in any given code object (single function or block compilation.)") + + +;;; INLINE-EXPANSION-OK -- Interface +;;; +;;; Check if Node's component has exceeded its inline expansion limit, and +;;; warn if so, returning NIL. +;;; +(defun inline-expansion-ok (node) + (let ((expanded (incf (component-inline-expansions + (block-component + (node-block node)))))) + (cond ((> expanded *inline-expansion-limit*) nil) + ((= expanded *inline-expansion-limit*) + (let ((*compiler-error-context* node)) + (compiler-warning "*Inline-Expansion-Limit* (~D) exceeded, ~ + probably trying to inline a recursive function." + *inline-expansion-limit*)) + nil) + (t t)))) + ;;;; Compiler error context determination: -- GitLab