From: William Harold Newman Date: Sun, 6 Jan 2002 00:24:38 +0000 (+0000) Subject: 0.pre7.114: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=b05f52060838600d14b5d8ad4604a61351dd7017;p=sbcl.git 0.pre7.114: more name tweaks... ...If we do use an abbreviation, I'd like it to be used consistently. s/xep/external-entry-point/ looks too verbose to be palatable (MAKE-EXTERNAL-ENTRY-POINT-LAMBDA-EXPRESSION, ouch) so s/external-entry-point/xep/ instead. fixed the "&MORE processor" function debug name syndrome... ...added SOURCE-NAME and DEBUG-NAME arguments to the various IR1-CONVERT-FOO functions running up to IR1-CONVERT-MORE... ...IR1-CONVERT-HAIRY-ARGS ...GENERATE-OPTIONAL-DEFAULT-ENTRY ...IR1-CONVERT-MORE itself ...made IR1-CONVERT-MORE use the names to make a debug name which identifies the parent function ...free bonus: made IR1-CONVERT-HAIRY-ARGS use SOURCE-NAME and DEBUG-NAME to build a better (than "hairy arg processor) debug name for its own IR1-CONVERT-LAMBDA-BODY call ...(Check for analogous internal uses of debug-name-ish stuff in GENERATE-OPTIONAL-DEFAULT-ENTRY, but there are none.) defined AS-DEBUG-NAME to support this --- diff --git a/BUGS b/BUGS index aa4c59b..2e4eab5 100644 --- a/BUGS +++ b/BUGS @@ -1343,6 +1343,22 @@ Error in function C::GET-LAMBDA-TO-COMPILE: which fails for the test case above but doesn't keep the system from cross-compiling itself or passing its tests. + I traced IR1-CONVERT-LAMBDA (with :PRINT *CURRENT-COMPONENT*) + and tracing various COMPONENT-manipulating functions like + FIND-INITIAL-DFO, DFO-SCAVENGE-DEPENDENCY-GRAPH, + JOIN-COMPONENTS, LOCALL-ANALYZE-COMPONENT, etc. From that, + it looks as though the problem is that IR1-CONVERT-LAMBDA + is being called by MAKE-EXTERNAL-ENTRY-POINT to + create the mislaid LAMBDA in an environment set up by + WITH-BELATED-IR1-ENVIRONMENT which has *CURRENT-COMPONENT* set + to a component which is never seen again, and specifically never + passed to LOCALL-ANALYZE-COMPONENT or JOIN-COMPONENTS, so that + its NEW-FUNS list (where the mislaid LAMBDA is waiting patiently) + gets lost. Thus, the LAMBDA is essentially being written into never + never land. But I haven't figured out why. *CURRENT-COMPONENT* is set + wrong? Something later on is dropping the ball and neglecting + to look at all the components it should? Something else? + 139: In sbcl-0.pre7.107, (DIRECTORY "*.*") is broken, as reported by Nathan Froyd sbcl-devel 2001-12-28. diff --git a/src/compiler/control.lisp b/src/compiler/control.lisp index 76390e4..9259a02 100644 --- a/src/compiler/control.lisp +++ b/src/compiler/control.lisp @@ -188,7 +188,7 @@ (clear-flags component) (dolist (fun (component-lambdas component)) - (when (external-entry-point-p fun) + (when (xep-p fun) (control-analyze-1-fun fun component block-info-constructor))) (dolist (fun (component-lambdas component)) diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index fdfdd67..5a0df42 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -512,7 +512,7 @@ (setf (compiled-debug-fun-tlf-number dfun) tlf-num) (setf (compiled-debug-fun-blocks dfun) blocks))) - (if (external-entry-point-p fun) + (if (xep-p fun) (setf (compiled-debug-fun-returns dfun) :standard) (let ((info (tail-set-info (lambda-tail-set fun)))) (when info diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 3ae89d9..19c3c64 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -838,8 +838,7 @@ (unless (or (eq (global-conflicts-kind conf) :write) (eq tn pc) (eq tn fp) - (and (external-entry-point-p fun) - (tn-offset tn)) + (and (xep-p fun) (tn-offset tn)) (member (tn-kind tn) '(:environment :debug-environment)) (member tn vars :key #'leaf-info) (member tn closure :key #'cdr)) diff --git a/src/compiler/entry.lisp b/src/compiler/entry.lisp index 8b7bfd6..aad3908 100644 --- a/src/compiler/entry.lisp +++ b/src/compiler/entry.lisp @@ -23,7 +23,7 @@ (defun entry-analyze (component) (let ((2comp (component-info component))) (dolist (fun (component-lambdas component)) - (when (external-entry-point-p fun) + (when (xep-p fun) (let ((info (or (leaf-info fun) (setf (leaf-info fun) (make-entry-info))))) (compute-entry-info fun info) diff --git a/src/compiler/gtn.lisp b/src/compiler/gtn.lisp index 58755f1..0aa7f2b 100644 --- a/src/compiler/gtn.lisp +++ b/src/compiler/gtn.lisp @@ -75,7 +75,7 @@ (let ((res (make-ir2-physenv :closure (nreverse reversed-ir2-physenv-alist) :return-pc-pass (make-return-pc-passing-location - (external-entry-point-p clambda))))) + (xep-p clambda))))) (setf (physenv-info lambda-physenv) res) (setf (ir2-physenv-old-fp res) (make-old-fp-save-location lambda-physenv)) @@ -111,7 +111,7 @@ (defun use-standard-returns (tails) (declare (type tail-set tails)) (let ((funs (tail-set-funs tails))) - (or (and (find-if #'external-entry-point-p funs) + (or (and (find-if #'xep-p funs) (find-if #'has-full-call-use funs)) (block punt (dolist (fun funs t) @@ -192,7 +192,7 @@ (return (lambda-return fun))) (when (and return (not (eq (return-info-kind returns) :unknown)) - (external-entry-point-p fun)) + (xep-p fun)) (do-uses (use (return-result return)) (setf (node-tail-p use) nil)))) (values)) diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index 5a77869..c12736a 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -208,6 +208,27 @@ (*print-level* 2)) (apply #'format nil format-string format-arguments)))) +;;; shorthand for a repeated idiom in creating debug names +;;; +;;; the problem, part I: We want to create debug names that look like +;;; "&MORE processor for " where might be +;;; either a source-name value (typically a symbol) or a non-symbol +;;; debug-name value (typically a string). It's awkward to handle this +;;; with FORMAT because we'd like to splice a source-name value using +;;; "~S" (to get package qualifiers) but a debug-name value using "~A" +;;; (to avoid irrelevant quotes at string splice boundaries). +;;; +;;; the problem, part II: The is represented as a pair +;;; of values, SOURCE-NAME and DEBUG-NAME, where SOURCE-NAME is used +;;; if it's not null. +;;; +;;; the solution: Use this function to convert whatever it is to a +;;; string, which FORMAT can then splice using "~A". +(defun as-debug-name (source-name debug-name) + (if source-name + (debug-namify "~S" source-name) + debug-name)) + ;;; Return a COMPILER-ERROR-CONTEXT structure describing the current ;;; error context, or NIL if we can't figure anything out. ARGS is a ;;; list of things that are going to be printed out in the error diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 1a7927f..00e8a19 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1274,6 +1274,10 @@ ;;; sequentially bind each AUX-VAR to the corresponding AUX-VAL before ;;; converting the body. If there are no bindings, just convert the ;;; body, otherwise do one binding and recurse on the rest. +;;; +;;; FIXME: This could and probably should be converted to use +;;; SOURCE-NAME and DEBUG-NAME. But I (WHN) don't use &AUX bindings, +;;; so I'm not motivated. Patches will be accepted... (defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals) (declare (type continuation start cont) (list body aux-vars aux-vals)) (if (null aux-vars) @@ -1454,7 +1458,8 @@ (defun generate-optional-default-entry (res default-vars default-vals entry-vars entry-vals vars supplied-p-p body - aux-vars aux-vals cont) + aux-vars aux-vals cont + source-name debug-name) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals vars body aux-vars aux-vals) @@ -1470,14 +1475,16 @@ (list* (leaf-source-name supplied-p) arg-name default-vals) (cons arg entry-vars) (list* t arg-name entry-vals) - (rest vars) t body aux-vars aux-vals cont) + (rest vars) t body aux-vars aux-vals cont + source-name debug-name) (ir1-convert-hairy-args res (cons arg default-vars) (cons arg-name default-vals) (cons arg entry-vars) (cons arg-name entry-vals) - (rest vars) supplied-p-p body aux-vars aux-vals cont)))) + (rest vars) supplied-p-p body aux-vars aux-vals cont + source-name debug-name)))) (convert-optional-entry ep default-vars default-vals (if supplied-p @@ -1622,7 +1629,8 @@ ;;; type when computing the type for the main entry's argument. (defun ir1-convert-more (res default-vars default-vals entry-vars entry-vals rest more-context more-count keys supplied-p-p - body aux-vars aux-vals cont) + body aux-vars aux-vals cont + source-name debug-name) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals keys body aux-vars aux-vals) @@ -1683,7 +1691,10 @@ :aux-vars (append (bind-vars) aux-vars) :aux-vals (append (bind-vals) aux-vals) :result cont - :debug-name (debug-namify "~S processor" '&more))) + :debug-name (debug-namify "~S processor for ~A" + '&more + (as-debug-name source-name + debug-name)))) (last-entry (convert-optional-entry main-entry default-vars (main-vals) ()))) (setf (optional-dispatch-main-entry res) main-entry) @@ -1730,7 +1741,8 @@ (defun ir1-convert-hairy-args (res default-vars default-vals entry-vars entry-vals vars supplied-p-p body aux-vars - aux-vals cont) + aux-vals cont + source-name debug-name) (declare (type optional-dispatch res) (list default-vars default-vals entry-vars entry-vals vars body aux-vars aux-vals) @@ -1741,13 +1753,16 @@ (ir1-convert-more res default-vars default-vals entry-vars entry-vals nil nil nil vars supplied-p-p body aux-vars - aux-vals cont) + aux-vals cont source-name debug-name) (let ((fun (ir1-convert-lambda-body body (reverse default-vars) :aux-vars aux-vars :aux-vals aux-vals :result cont - :debug-name "hairy arg processor"))) + :debug-name (debug-namify + "hairy arg processor for ~A" + (as-debug-name source-name + debug-name))))) (setf (optional-dispatch-main-entry res) fun) (push (if supplied-p-p (convert-optional-entry fun entry-vars entry-vals ()) @@ -1760,7 +1775,8 @@ (nvals (cons (leaf-source-name arg) default-vals))) (ir1-convert-hairy-args res nvars nvals nvars nvals (rest vars) nil body aux-vars aux-vals - cont))) + cont + source-name debug-name))) (t (let* ((arg (first vars)) (info (lambda-var-arg-info arg)) @@ -1770,7 +1786,8 @@ (let ((ep (generate-optional-default-entry res default-vars default-vals entry-vars entry-vals vars supplied-p-p body - aux-vars aux-vals cont))) + aux-vars aux-vals cont + source-name debug-name))) (push (if supplied-p-p (convert-optional-entry ep entry-vars entry-vals ()) ep) @@ -1780,17 +1797,19 @@ (ir1-convert-more res default-vars default-vals entry-vars entry-vals arg nil nil (rest vars) supplied-p-p body - aux-vars aux-vals cont)) + aux-vars aux-vals cont + source-name debug-name)) (:more-context (ir1-convert-more res default-vars default-vals entry-vars entry-vals nil arg (second vars) (cddr vars) supplied-p-p - body aux-vars aux-vals cont)) + body aux-vars aux-vals cont + source-name debug-name)) (:keyword (ir1-convert-more res default-vars default-vals entry-vars entry-vals nil nil nil vars supplied-p-p body aux-vars - aux-vals cont))))))) + aux-vals cont source-name debug-name))))))) ;;; This function deals with the case where we have to make an ;;; OPTIONAL-DISPATCH to represent a LAMBDA. We cons up the result and @@ -1811,7 +1830,7 @@ (min (or (position-if #'lambda-var-arg-info vars) (length vars)))) (push res (component-new-funs *current-component*)) (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals - cont) + cont source-name debug-name) (setf (optional-dispatch-min-args res) min) (setf (optional-dispatch-max-args res) (+ (1- (length (optional-dispatch-entry-points res))) min)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index fe51581..79ca83e 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1108,7 +1108,7 @@ (not (block-delete-p block)))))))) ;;; Delete all the blocks and functions in COMPONENT. We scan first -;;; marking the blocks as delete-p to prevent weird stuff from being +;;; marking the blocks as DELETE-P to prevent weird stuff from being ;;; triggered by deletion. (defun delete-component (component) (declare (type component component)) @@ -1261,9 +1261,10 @@ (t (return nil))))))) -;;; Return true if function is an XEP. This is true of normal XEPs -;;; (:EXTERNAL kind) and top level lambdas (:TOPLEVEL kind.) -(defun external-entry-point-p (fun) +;;; Return true if function is an external entry point. This is true +;;; of normal XEPs (:EXTERNAL kind) and also of top level lambdas +;;; (:TOPLEVEL kind.) +(defun xep-p (fun) (declare (type functional fun)) (not (null (member (functional-kind fun) '(:external :toplevel))))) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 1ff1709..db462db 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1107,7 +1107,7 @@ (aver (member (functional-kind fun) '(nil :external :optional :toplevel :cleanup))) - (when (external-entry-point-p fun) + (when (xep-p fun) (init-xep-environment node block fun) #!+sb-dyncount (when *collect-dynamic-statistics* @@ -1146,7 +1146,7 @@ (returns (tail-set-info (lambda-tail-set fun)))) (cond ((and (eq (return-info-kind returns) :fixed) - (not (external-entry-point-p fun))) + (not (xep-p fun))) (let ((locs (continuation-tns node block cont (return-info-types returns)))) (vop* known-return node block @@ -1569,8 +1569,7 @@ (when *collect-dynamic-statistics* (let ((first-node (continuation-next (block-start block)))) (unless (or (and (bind-p first-node) - (external-entry-point-p - (bind-lambda first-node))) + (xep-p (bind-lambda first-node))) (eq (continuation-fun-name (node-cont first-node)) '%nlx-entry)) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 5351b32..4e45c0b 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -175,7 +175,7 @@ ;;; ;;; We set REANALYZE and REOPTIMIZE in the component, just in case we ;;; discover an XEP after the initial local call analyze pass. -(defun make-external-entry-point (fun) +(defun make-xep (fun) (declare (type functional fun)) (aver (not (functional-entry-fun fun))) (with-belated-ir1-environment (lambda-bind (main-entry fun)) @@ -207,10 +207,10 @@ (defun reference-entry-point (ref) (declare (type ref ref)) (let ((fun (ref-leaf ref))) - (unless (or (external-entry-point-p fun) + (unless (or (xep-p fun) (member (functional-kind fun) '(:escape :cleanup))) (change-ref-leaf ref (or (functional-entry-fun fun) - (make-external-entry-point fun)))))) + (make-xep fun)))))) ;;; Attempt to convert all references to FUN to local calls. The ;;; reference must be the function for a call, and the function @@ -387,7 +387,7 @@ (node-block (lambda-bind (main-entry original-fun)))) component)))) - (let ((fun (if (external-entry-point-p original-fun) + (let ((fun (if (xep-p original-fun) (functional-entry-fun original-fun) original-fun)) (*compiler-error-context* call)) @@ -528,7 +528,7 @@ `(lambda ,vars (declare (ignorable . ,ignores)) (%funcall ,entry . ,args)) - :debug-name (debug-namify "hairy fun entry ~S" + :debug-name (debug-namify "hairy function entry ~S" (continuation-fun-name (basic-combination-fun call))))))) (convert-call ref call new-fun) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index af9ba1d..17a2539 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -857,10 +857,10 @@ (setf (component-name component) (debug-namify "~S initial component" name)) (setf (component-kind component) :initial) - (let* ((locall-fun (ir1-convert-lambda definition - :debug-name (debug-namify - "top level locall ~S" - name))) + (let* ((locall-fun (ir1-convert-lambda + definition + :debug-name (debug-namify "top level local call ~S" + name))) (fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun) :source-name (or name '.anonymous.) :debug-name (unless name diff --git a/version.lisp-expr b/version.lisp-expr index b23e666..aa2c67e 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.113" +"0.pre7.114"