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
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.
(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))
(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
(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))
(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)
(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))
(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)
(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))
(*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 <something>" where <something> 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 <something> 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
;;; 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)
(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)
(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
;;; 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)
: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)
(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)
(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 ())
(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))
(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)
(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
(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))
(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))
(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)))))
(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*
(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
(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))
;;;
;;; 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))
(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))))))
\f
;;; Attempt to convert all references to FUN to local calls. The
;;; reference must be the function for a call, and the function
(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))
`(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)
(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
;;; 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"
projects / sbcl.git / commitdiff