wrong? Something later on is dropping the ball and neglecting
to look at all the components it should? Something else?
+ Tracing more things like IR1-PHASES and COMPILE-COMPONENT, it
+ looks as though the problem is that WITH-BELATED-IR1-ENVIRONMENT
+ is binding *CURRENT-COMPONENT* (i.e., where new code will be inserted)
+ to a COMPONENT which has already been passed to COMPILE-COMPONENT
+ (once and for all, so it'll never pass that way again). It seems
+ as though there's a broken invariant there: *CURRENT-COMPONENT*
+ should never be something which has already been COMPILE-COMPONENTed.
+
139:
In sbcl-0.pre7.107, (DIRECTORY "*.*") is broken, as reported by
Nathan Froyd sbcl-devel 2001-12-28.
(trace-1 fname info new-value)))))
(push #'trace-redefined-update *setf-fdefinition-hook*)
-;;; Annotate some forms to evaluate with pre-converted functions. Each
-;;; form is really a cons (exp . function). Loc is the code location
-;;; to use for the lexical environment. If Loc is NIL, evaluate in the
-;;; null environment. If Form is NIL, just return NIL.
+;;; Annotate a FORM to evaluate with pre-converted functions. FORM is
+;;; really a cons (EXP . FUNCTION). LOC is the code location to use
+;;; for the lexical environment. If LOC is NIL, evaluate in the null
+;;; environment. If FORM is NIL, just return NIL.
(defun coerce-form (form loc)
(when form
(let ((exp (car form)))
(declare (ignore frame))
(let ((*current-frame* nil))
(funcall fun)))))))))
+
(defun coerce-form-list (forms loc)
(mapcar #'(lambda (x) (coerce-form x loc)) forms))
(defun trace-start-breakpoint-fun (info)
(let (conditionp)
(values
+
#'(lambda (frame bpt)
(declare (ignore bpt))
(discard-invalid-entries frame)
(funcall (cdr condition) frame))
(or (not wherein)
(trace-wherein-p frame wherein)))))
-
(when conditionp
(let ((sb-kernel:*current-level* 0)
(*standard-output* *trace-output*)
;;; passes them on to CONT.
(defun convert-type-check (cont types)
(declare (type continuation cont) (type list types))
- (with-belated-ir1-environment (continuation-dest cont)
+ (with-ir1-environment-from-node (continuation-dest cont)
;; Ensuring that CONT starts a block lets us freely manipulate its uses.
(ensure-block-start cont)
#!+sb-doc
"FUNCTION Name
Return the lexically apparent definition of the function Name. Name may also
- be a lambda."
+ be a lambda expression."
(if (consp thing)
(case (car thing)
((lambda)
;;; become unreachable, resulting in a spurious note.
(defun convert-if-if (use node)
(declare (type node use) (type cif node))
- (with-belated-ir1-environment node
+ (with-ir1-environment-from-node node
(let* ((block (node-block node))
(test (if-test node))
(cblock (if-consequent node))
(change-ref-leaf ref res))))
(if ir1-p
(frob)
- (with-belated-ir1-environment call
+ (with-ir1-environment-from-node call
(frob)
(locall-analyze-component *current-component*))))
;;; integrated into the control flow.
(defun transform-call (node res)
(declare (type combination node) (list res))
- (with-belated-ir1-environment node
+ (with-ir1-environment-from-node node
(let ((new-fun (ir1-convert-inline-lambda
res
- :debug-name "<something inlined in TRANSFORM-CALL>"))
+ :debug-name "something inlined in TRANSFORM-CALL"))
(ref (continuation-use (combination-fun node))))
(change-ref-leaf ref new-fun)
(setf (combination-kind node) :full)
min)
(t nil))))
(when count
- (with-belated-ir1-environment node
+ (with-ir1-environment-from-node node
(let* ((dums (make-gensym-list count))
(ignore (gensym))
(fun (ir1-convert-lambda
(mapc #'flush-dest (subseq vals nvars))
(setq vals (subseq vals 0 nvars)))
((< nvals nvars)
- (with-belated-ir1-environment use
+ (with-ir1-environment-from-node use
(let ((node-prev (node-prev use)))
(setf (node-prev use) nil)
(setf (continuation-next node-prev) nil)
;;; FIXME: It's confusing having one variable named *CURRENT-COMPONENT*
;;; and another named *COMPONENT-BEING-COMPILED*. (In CMU CL they
;;; were called *CURRENT-COMPONENT* and *COMPILE-COMPONENT* respectively,
-;;; which also confusing.)
+;;; which was also confusing.)
(declaim (type (or component null) *current-component*))
(defvar *current-component*)
;;; Add FUN to the COMPONENT-REANALYZE-FUNS. FUN is returned.
(defun maybe-reanalyze-fun (fun)
(declare (type functional fun))
+ (aver-live-component *current-component*)
(when (typep fun '(or optional-dispatch clambda))
(pushnew fun (component-reanalyze-funs *current-component*)))
fun)
debug-name)
(declare (list body vars aux-vars aux-vals)
(type (or continuation null) result))
+
+ ;; We're about to try to put new blocks into *CURRENT-COMPONENT*.
+ (aver-live-component *current-component*)
+
(let* ((bind (make-bind))
(lambda (make-lambda :vars vars
:bind bind
(link-blocks (component-head *current-component*) (node-block bind))
(push lambda (component-new-funs *current-component*))
+
lambda))
;;; Create the actual entry-point function for an optional entry
:aux-vars (append (bind-vars) aux-vars)
:aux-vals (append (bind-vals) aux-vals)
:result cont
- :debug-name (debug-namify "~S processor for ~A"
- '&more
+ :debug-name (debug-namify "varargs entry point for ~A"
(as-debug-name source-name
debug-name))))
(last-entry (convert-optional-entry main-entry default-vars
:%source-name source-name
:%debug-name debug-name))
(min (or (position-if #'lambda-var-arg-info vars) (length vars))))
+ (aver-live-component *current-component*)
(push res (component-new-funs *current-component*))
(ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals
cont source-name debug-name)
;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf.
(defun ir1-convert-lambda (form &key (source-name '.anonymous.) debug-name)
+
(unless (consp form)
(compiler-error "A ~S was found when expecting a lambda expression:~% ~S"
(type-of form)
(declare (type cblock block1 block2) (type node node)
(type (or cleanup null) cleanup))
(setf (component-reanalyze (block-component block1)) t)
- (with-belated-ir1-environment node
+ (with-ir1-environment-from-node node
(let* ((start (make-continuation))
(block (continuation-starts-block start))
(cont (make-continuation))
(aver (and succ (null (cdr succ))))
(cond
((member block succ)
- (with-belated-ir1-environment node
+ (with-ir1-environment-from-node node
(let ((exit (make-exit))
(dummy (make-continuation)))
(setf (continuation-next prev) nil)
(defun make-xep (fun)
(declare (type functional fun))
(aver (not (functional-entry-fun fun)))
- (with-belated-ir1-environment (lambda-bind (main-entry fun))
+ (with-ir1-environment-from-node (lambda-bind (main-entry fun))
(let ((res (ir1-convert-lambda (make-xep-lambda-expression fun)
:debug-name (debug-namify
"XEP for ~A"
;;; NEW-FUNS, but we don't add lambdas to the LAMBDAS.
(defun locall-analyze-component (component)
(declare (type component component))
+ (aver-live-component component)
(loop
(let* ((new-fun (pop (component-new-funs component)))
(fun (or new-fun (pop (component-reanalyze-funs component)))))
(and (>= speed space) (>= speed compilation-speed)))
(not (eq (functional-kind (node-home-lambda call)) :external))
(inline-expansion-ok call))
- (with-belated-ir1-environment call
+ (with-ir1-environment-from-node call
(let* ((*lexenv* (functional-lexenv fun))
(won nil)
(res (catch 'local-call-lossage
(declare (list vars ignores args) (type ref ref) (type combination call)
(type clambda entry))
(let ((new-fun
- (with-belated-ir1-environment call
+ (with-ir1-environment-from-node call
(ir1-convert-lambda
`(lambda ,vars
(declare (ignorable . ,ignores))
(let* ((call-block (node-block call))
(bind-block (node-block (lambda-bind clambda)))
(component (block-component call-block)))
+ (aver-live-component component)
(let ((clambda-component (block-component bind-block)))
(unless (eq clambda-component component)
(aver (eq (component-kind component) :initial))
(join-components component clambda-component)))
-
(let ((*current-component* component))
(node-ends-block call))
;; FIXME: Use PROPER-LIST-OF-LENGTH-P here, and look for other
`(eq ,node-var (block-last ,n-block))
`(eq ,cont-var ,n-last-cont))
(return nil))))))
-;;; like Do-Nodes, only iterating in reverse order
+;;; like DO-NODES, only iterating in reverse order
(defmacro do-nodes-backwards ((node-var cont-var block) &body body)
(let ((n-block (gensym))
(n-start (gensym))
(when (eq ,n-next ,n-start)
(return nil))))))
-;;; Bind the IR1 context variables so that IR1 conversion can be done
-;;; after the main conversion pass has finished.
-;;;
-;;; The lexical environment is presumably already null...
-(defmacro with-belated-ir1-environment (node &rest forms)
- (let ((n-node (gensym)))
- `(let* ((,n-node ,node)
- (*current-component* (block-component (node-block ,n-node)))
- (*lexenv* (node-lexenv ,n-node))
- (*current-path* (node-source-path ,n-node)))
- ,@forms)))
+;;; Bind the IR1 context variables to the values associated with NODE,
+;;; so that new, extra IR1 conversion related to NODE can be done
+;;; after the original conversion pass has finished.
+(defmacro with-ir1-environment-from-node (node &rest forms)
+ `(flet ((closure-needing-ir1-environment-from-node ()
+ ,@forms))
+ (%with-ir1-environment-from-node
+ ,node
+ #'closure-needing-ir1-environment-from-node)))
+(defun %with-ir1-environment-from-node (node fun)
+ (declare (type node node) (type function fun))
+ (let ((*current-component* (block-component (node-block node)))
+ (*lexenv* (node-lexenv node))
+ (*current-path* (node-source-path node)))
+ (aver-live-component *current-component*)
+ (funcall fun)))
;;; Bind the hashtables used for keeping track of global variables,
;;; functions, etc. Also establish condition handlers.
;;; Do all the IR1 phases for a non-top-level component.
(defun ir1-phases (component)
(declare (type component component))
+ (aver-live-component component)
(let ((*constraint-number* 0)
(loop-count 1)
(*delayed-ir1-transforms* nil))
(null))))))
;; We're done, so don't bother keeping anything around.
- (setf (component-info component) nil)
+ (setf (component-info component) :dead)
(values))
(return))))))
(defun compile-component (component)
+ (aver-live-component component)
(let* ((*component-being-compiled* component))
(when sb!xc:*compile-print*
(compiler-mumble "~&; compiling ~A: " (component-name component)))
(let ((lambda (compile-load-time-stuff `(progn ,@forms) name nil)))
(fasl-dump-toplevel-lambda-call lambda *compile-object*)))
-;;; Does the actual work of COMPILE-LOAD-TIME-VALUE or
-;;; COMPILE-MAKE-LOAD-FORM- INIT-FORMS.
+;;; Do the actual work of COMPILE-LOAD-TIME-VALUE or
+;;; COMPILE-MAKE-LOAD-FORM-INIT-FORMS.
(defun compile-load-time-stuff (form name for-value)
(with-ir1-namespace
(let* ((*lexenv* (make-null-lexenv))
(out nil)
;; the component this block is in, or NIL temporarily during IR1
;; conversion and in deleted blocks
- (component *current-component* :type (or component null))
+ (component (progn
+ (aver-live-component *current-component*)
+ *current-component*)
+ :type (or component null))
;; a flag used by various graph-walking code to determine whether
;; this block has been processed already or what. We make this
;; initially NIL so that FIND-INITIAL-DFO doesn't have to scan the
;; The IR1 block that this block is in the INFO for.
(block (missing-arg) :type cblock)
;; the next and previous block in emission order (not DFO). This
- ;; determines which block we drop though to, and also used to chain
- ;; together overflow blocks that result from splitting of IR2 blocks
- ;; in lifetime analysis.
+ ;; determines which block we drop though to, and is also used to
+ ;; chain together overflow blocks that result from splitting of IR2
+ ;; blocks in lifetime analysis.
(next nil :type (or block-annotation null))
(prev nil :type (or block-annotation null)))
(reanalyze nil :type boolean)
;; some sort of name for the code in this component
(name "<unknown>" :type simple-string)
- ;; some kind of info used by the back end
- (info nil)
+ ;; When I am a child, this is :NO-IR2-YET.
+ ;; In my adulthood, IR2 stores notes to itself here.
+ ;; After I have left the great wheel and am staring into the GC, this
+ ;; is set to :DEAD to indicate that it's a gruesome error to operate
+ ;; on me (e.g. by using me as *CURRENT-COMPONENT*, or by pushing
+ ;; LAMBDAs onto my NEW-FUNS, as in sbcl-0.pre7.115).
+ (info :no-ir2-yet :type (or ir2-component (member :no-ir2-yet :dead)))
;; the SOURCE-INFO structure describing where this component was
;; compiled from
(source-info *source-info* :type source-info)
name
(reanalyze :test reanalyze))
+;;; Check that COMPONENT is suitable for roles which involve adding
+;;; new code. (gotta love imperative programming with lotso in-place
+;;; side-effects...)
+(defun aver-live-component (component)
+ ;; FIXME: As of sbcl-0.pre7.115, we're asserting that
+ ;; COMPILE-COMPONENT hasn't happened yet. Might it be even better
+ ;; (certainly stricter, possibly also correct...) to assert that
+ ;; IR1-FINALIZE hasn't happened yet?
+ (aver (not (eql (component-info component) :dead))))
+
;;; Before sbcl-0.7.0, there were :TOPLEVEL things which were magical
;;; in multiple ways. That's since been refactored into the orthogonal
;;; properties "optimized for locall with no arguments" and "externally
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.114"
+"0.pre7.115"
projects / sbcl.git / commitdiff