(defclass ccc () ())
(setf (find-class 'ccc1) (find-class 'ccc))
(defmethod zut ((c ccc1)) 123)
+ In sbcl-0.7.1.13, this gives an error,
+ There is no class named CCC1.
DTC's recommended workaround from the mailing list 3 Mar 2000:
(setf (pcl::find-class 'ccc1) (pcl::find-class 'ccc))
it with only one entry in LEAF-REFS.
148:
- In sbcl-0.7.1.3 on x86, COMPILE-FILE on this file
+ In sbcl-0.7.1.3 on x86, COMPILE-FILE on the file
(in-package :cl-user)
(defvar *thing*)
(defvar *zoom*)
fails with
debugger invoked on condition of type TYPE-ERROR:
The value NIL is not of type SB-C::NODE.
- in IR1-OPTIMIZE-BLOCK.
-
+ The location of this failure has moved around as various related
+ issues were cleaned up. As of sbcl-0.7.1.9, it occurs in
+ NODE-BLOCK called by LAMBDA-COMPONENT called by IR2-CONVERT-CLOSURE.
+
+149:
+ (reported by Stig E Sandoe sbcl-devel 2002-02-02)
+ In sbcl-0.7.1.13, compiling a DEFCLASS FOO form isn't enough to make
+ the class known to the compiler for other forms compiled in the same
+ file, so bogus warnings "undefined type: FOO" are generated, e.g.
+ when compiling
+ (in-package :cl-user)
+ (defclass foo () ())
+ (defun bar (x)
+ (typep x 'foo))
DEFUNCT CATEGORIES OF BUGS
IR1-#:
needed now that the byte interpreter is gone) caused the fasl
file format number to change again.
+changes in sbcl-0.7.2 relative to sbcl-0.7.1:
+ ?? incompatible change: The compiler is now less aggressive about
+ tail call optimization, doing it only when (> SPACE DEBUG). (This
+ is an incompatible change because there are programs which depended
+ on the old CMU-CL-style behavior to optimize away their unbounded
+ recursion which will now die of stack overflow.)
+ * several changes related to debugging:
+ ?? suppression of tail recursion, as noted above
+ ** The default implementation of TRACE has changed. :ENCAPSULATE T
+ is now the default. (For some time encapsulation has been more
+ reliable than the breakpoint-based :ENCAPSULATE NIL
+ implementation, at least on X86 systems; and I just noticed that
+ encapsulation also seems closer to the spirit of the ANSI
+ specification.)
+ ?? TRACE :ENCAPSULATE T now attaches a more informative debug
+ name to its wrapper function objects than it used to
+
planned incompatible changes in 0.7.x:
* When the profiling interface settles down, maybe in 0.7.x, maybe
later, it might impact TRACE. They both encapsulate functions, and
(so that slam.sh will run faster and also just because
ideally everything would be in cold init)
** profiled and tweaked
+* fixed (TRACE :REPORT PROFILE ...) interface to profiling
* more EVAL/EVAL-WHEN/%COMPILE/DEFUN/DEFSTRUCT cleanup:
** made %COMPILE understand magicality of DEFUN FOO
w.r.t. e.g. preexisting inlineness of FOO
are now implemented as closures (because
they're structure slot accessors) won't be so
nasty in the debugger
- ** %SLOT-ACCESSOR/%SLOT-ACCESSOR stuff can probably go away,
- since we inline expand all slot accessors into
- %INSTANCE-REF and the optimizer knows all it needs
- to know about that.
* rewrote long-standing confusing error restarts for redefining
DEFSTRUCTs
* outstanding embarrassments
** cut-and-pasted DEF-BOOLEAN-ATTRIBUTE (maybe easier to fix
- now that EVAL-WHEN does what it should..)
+ now that EVAL-WHEN works correctly..)
** incomplete manual
** :IGNORE-ERRORS-P cruft in stems-and-flags.lisp-expr. (It's
reasonable to support this as a crutch when initially
out of scope. (However, it still might be possible to
determine that some or all of them are hopelessly stale
and delete them.)
-===============================================================================
+=======================================================================
other known issues with no particular target date:
bugs listed on the man page
# standard clean.sh file.)
# Ask some other directories to clean themselves up.
-pwd=`pwd`
+original_pwd=`pwd`
for d in tools-for-build; do
- cd $d
+ cd $d > /dev/null
# I hope the -s option is standard. At least GNU make and BSD make
# support it. It silences make, since otherwise the output from
# this script is just the operations done by these make's, which
# is misleading when this script does lotso other operations too.
# -- WHN
make -s clean
- cd $pwd
+ cd $original_pwd > /dev/null
done
# Within all directories, remove things which don't look like source
# that we used to compile it:
# (1) It reduces the chance that the cross-compilation process
# inadvertently comes to depend on some weird compile-time
-# side-effect.
+# side effect.
# (2) It reduces peak memory demand (because definitions wrapped in
# (EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE) ..) aren't defined
# in the fresh image).
-#!/bin/sh
+'#!/bin/sh
# "When we build software, it's a good idea to have a reliable method
# for getting an executable from it. We want any two reconstructions
#!+sb-doc
"Return a hash-table mapping string VOP names to VOP-STATS structures
describing the VOPs executed. If clear is true, then reset all counts to
- zero as a side-effect."
+ zero as a side effect."
(locally
(declare (optimize (speed 3) (safety 0))
(inline sb!vm::map-allocated-objects))
(setf (gethash (car x) ht) (cadr x))))
ht))))
\f
-;;;; SETQ hackery
+;;;; SETQ hackery, including destructuring ("DESETQ")
(defun loop-make-psetq (frobs)
(and frobs
(make-symbol "LOOP-DESETQ-TEMP"))
(sb!int:defmacro-mundanely loop-really-desetq (&environment env
- &rest var-val-pairs)
+ &rest var-val-pairs)
(labels ((find-non-null (var)
- ;; see whether there's any non-null thing here
- ;; recurse if the list element is itself a list
+ ;; See whether there's any non-null thing here. Recurse
+ ;; if the list element is itself a list.
(do ((tail var)) ((not (consp tail)) tail)
(when (find-non-null (pop tail)) (return t))))
(loop-desetq-internal (var val &optional temp)
(typecase var
(null
(when (consp val)
- ;; Don't lose possible side-effects.
+ ;; Don't lose possible side effects.
(if (eq (car val) 'prog1)
- ;; These can come from psetq or desetq below.
- ;; Throw away the value, keep the side-effects.
+ ;; These can come from PSETQ or DESETQ below.
+ ;; Throw away the value, keep the side effects.
;; Special case is for handling an expanded POP.
(mapcan (lambda (x)
(and (consp x)
,@body)
`((let ((,temp ,val))
,@body))))
- ;; no cdring to do
+ ;; no CDRing to do
(loop-desetq-internal car `(car ,val) temp)))))
(otherwise
(unless (eq var val)
"If the trace indentation exceeds this value, then indentation restarts at
0.")
-(defvar *trace-encapsulate-default* :default
+(defvar *trace-encapsulate-default* nil
#+sb-doc
"the default value for the :ENCAPSULATE option to TRACE")
\f
;;; KLUDGE: We use DEF!STRUCT to define this not because we need to
;;; manipulate target package objects on the cross-compilation host,
;;; but only because its MAKE-LOAD-FORM function needs to be hooked
-;;; into the pre-CLOS DEF!STRUCT MAKE-LOAD-FORM system. The DEF!STRUCT
-;;; side-effect of defining a new PACKAGE type on the
+;;; into the pre-CLOS DEF!STRUCT MAKE-LOAD-FORM system so that we can
+;;; compile things like IN-PACKAGE in warm init before CLOS is set up.
+;;; The DEF!STRUCT side effect of defining a new PACKAGE type on the
;;; cross-compilation host is just a nuisance, and in order to avoid
;;; breaking the cross-compilation host, we need to work around it
;;; around by putting the new PACKAGE type (and the PACKAGEP predicate
;;; Named is true if the first argument is a symbol whose global
;;; function definition is to be called.
;;;
-;;; Return is either :Fixed, :Unknown or :Tail:
-;;; -- If :Fixed, then the call is for a fixed number of values, returned in
-;;; the standard passing locations (passed as result operands).
-;;; -- If :Unknown, then the result values are pushed on the stack, and the
-;;; result values are specified by the Start and Count as in the
+;;; Return is either :FIXED, :UNKNOWN or :TAIL:
+;;; -- If :FIXED, then the call is for a fixed number of values, returned
+;;; in the standard passing locations (passed as result operands).
+;;; -- If :UNKNOWN, then the result values are pushed on the stack, and
+;;; the result values are specified by the Start and Count as in the
;;; unknown-values continuation representation.
-;;; -- If :Tail, then do a tail-recursive call. No values are returned.
+;;; -- If :TAIL, then do a tail-recursive call. No values are returned.
;;; The Ocfp and Return-PC are passed as the second and third arguments.
;;;
;;; In non-tail calls, the pointer to the stack arguments is passed as
;;; the last fixed argument. If Variable is false, then the passing
;;; locations are passed as a more arg. Variable is true if there are
;;; a variable number of arguments passed on the stack. Variable
-;;; cannot be specified with :Tail return. TR variable argument call
+;;; cannot be specified with :TAIL return. TR variable argument call
;;; is implemented separately.
;;;
;;; In tail call with fixed arguments, the passing locations are
;; said that somewhere in here we
;; Set the new block's start and end cleanups to the *start*
;; cleanup of PREV's block. This overrides the incorrect
- ;; default from WITH-BELATED-IR1-ENVIRONMENT.
+ ;; default from WITH-IR1-ENVIRONMENT-FROM-NODE.
;; Unfortunately I can't find any code which corresponds to this.
;; Perhaps it was a stale comment? Or perhaps I just don't
;; understand.. -- WHN 19990521
block-info-constructor)))))))
(values))
-;;; Do control analysis on Component, finding the emit order. Our only
+;;; Do control analysis on COMPONENT, finding the emit order. Our only
;;; cleverness here is that we walk XEP's first to increase the
;;; probability that the tail call will be a drop-through.
;;;
\f
;;; Return a list of DEBUG-SOURCE structures containing information
;;; derived from INFO. Unless :BYTE-COMPILE T was specified, we always
-;;; dump the Start-Positions, since it is too hard figure out whether
+;;; dump the START-POSITIONS, since it is too hard figure out whether
;;; we need them or not.
(defun debug-source-for-info (info)
(declare (type source-info info))
(dolist (c components)
(let* ((head (component-head c))
(tail (component-tail c)))
- (unless (and (null (block-pred head)) (null (block-succ tail)))
+ (unless (and (null (block-pred head))
+ (null (block-succ tail)))
(barf "~S is malformed." c))
(do ((prev nil block)
(barf "The function for XEP ~S has kind." functional))
(unless (eq (functional-entry-fun fun) functional)
(barf "bad back-pointer in function for XEP ~S" functional))))
- ((:let :mv-let :assignment)
+ ((:let :mv-let :assignment) ; i.e. SOMEWHAT-LETLIKE-P
(check-fun-reached (lambda-home functional) functional)
(when (functional-entry-fun functional)
(barf "The LET ~S has entry function." functional))
(defun check-fun-consistency (components)
(dolist (c components)
- (dolist (new-fun (component-new-funs c))
+ (dolist (new-fun (component-new-functionals c))
(observe-functional new-fun))
(dolist (fun (component-lambdas c))
(when (eq (functional-kind fun) :external)
(observe-functional let))))
(dolist (c components)
- (dolist (new-fun (component-new-funs c))
+ (dolist (new-fun (component-new-functionals c))
(check-fun-stuff new-fun))
(dolist (fun (component-lambdas c))
(when (eq (functional-kind fun) :deleted)
(setf (component-lambdas new)
(nconc (component-lambdas old) (component-lambdas new)))
(setf (component-lambdas old) nil)
- (setf (component-new-funs new) (nconc (component-new-funs old)
- (component-new-funs new))
- (component-new-funs old) nil)
+ (setf (component-new-functionals new)
+ (nconc (component-new-functionals old)
+ (component-new-functionals new)))
+ (setf (component-new-functionals old) nil)
(dolist (xp (block-pred old-tail))
(unlink-blocks xp old-tail)
(declare (ignorable #'local-filter #'local-extract)
(inline (setf local-filtered-value)
local-filter local-extract))
- ;; Use them for side-effects only.
+ ;; Use them for side effects only.
(let* ,(make-arg-temp-bindings funstate)
,@(forms)))))))))
\f
(in-package "SB!C")
\f
-;;;; control special forms
+;;;; special forms for control
(def-ir1-translator progn ((&rest forms) start cont)
#!+sb-doc
(push env-entry (continuation-lexenv-uses cont))
(ir1-convert-progn-body dummy cont forms))))
-
(def-ir1-translator return-from ((name &optional value) start cont)
#!+sb-doc
"Return-From Block-Name Value-Form
;;; and doing IR1 optimizations. We can ignore all blocks that don't
;;; 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
-;;; is in a lambda that has been deleted. These blocks would
-;;; eventually be deleted by DFO recomputation, but doing it here
-;;; immediately makes the effect available to IR1 optimization.
(defun ir1-optimize (component)
(declare (type component component))
(setf (component-reoptimize component) nil)
(aver (not (block-delete-p block)))
(ir1-optimize-block block))
+ ;; We delete blocks when there is either no predecessor or the
+ ;; block is in a lambda that has been deleted. These blocks
+ ;; would eventually be deleted by DFO recomputation, but doing
+ ;; it here immediately makes the effect available to IR1
+ ;; optimization.
(when (and (block-flush-p block) (block-component block))
(aver (not (block-delete-p block)))
(flush-dead-code block)))))
(values))
-;;; Loop over the nodes in BLOCK, looking for stuff that needs to be
-;;; optimized. We dispatch off of the type of each node with its
-;;; reoptimize flag set:
-
-;;; -- With a COMBINATION, we call PROPAGATE-FUN-CHANGE whenever
-;;; the function changes, and call IR1-OPTIMIZE-COMBINATION if any
-;;; argument changes.
-;;; -- With an EXIT, we derive the node's type from the VALUE's type.
-;;; We don't propagate CONT's assertion to the VALUE, since if we
-;;; did, this would move the checking of CONT's assertion to the
-;;; exit. This wouldn't work with CATCH and UWP, where the EXIT
-;;; node is just a placeholder for the actual unknown exit.
+;;; Loop over the nodes in BLOCK, acting on (and clearing) REOPTIMIZE
+;;; flags.
;;;
-;;; Note that we clear the node & block reoptimize flags *before*
-;;; doing the optimization. This ensures that the node or block will
-;;; be reoptimized if necessary. We leave the NODE-OPTIMIZE flag set
-;;; going into IR1-OPTIMIZE-RETURN, since IR1-OPTIMIZE-RETURN wants to
-;;; clear the flag itself.
+;;; Note that although they are cleared here, REOPTIMIZE flags might
+;;; still be set upon return from this function, meaning that further
+;;; optimization is wanted (as a consequence of optimizations we did).
(defun ir1-optimize-block (block)
(declare (type cblock block))
+ ;; We clear the node and block REOPTIMIZE flags before doing the
+ ;; optimization, not after. This ensures that the node or block will
+ ;; be reoptimized if necessary.
(setf (block-reoptimize block) nil)
(do-nodes (node cont block :restart-p t)
(when (node-reoptimize node)
+ ;; As above, we clear the node REOPTIMIZE flag before optimizing.
(setf (node-reoptimize node) nil)
(typecase node
(ref)
(combination
+ ;; With a COMBINATION, we call PROPAGATE-FUN-CHANGE whenever
+ ;; the function changes, and call IR1-OPTIMIZE-COMBINATION if
+ ;; any argument changes.
(ir1-optimize-combination node))
(cif
(ir1-optimize-if node))
(creturn
+ ;; KLUDGE: We leave the NODE-OPTIMIZE flag set going into
+ ;; IR1-OPTIMIZE-RETURN, since IR1-OPTIMIZE-RETURN wants to
+ ;; clear the flag itself. -- WHN 2002-02-02, quoting original
+ ;; CMU CL comments
(setf (node-reoptimize node) t)
(ir1-optimize-return node))
(mv-combination
(ir1-optimize-mv-combination node))
(exit
+ ;; With an EXIT, we derive the node's type from the VALUE's
+ ;; type. We don't propagate CONT's assertion to the VALUE,
+ ;; since if we did, this would move the checking of CONT's
+ ;; assertion to the exit. This wouldn't work with CATCH and
+ ;; UWP, where the EXIT node is just a placeholder for the
+ ;; actual unknown exit.
(let ((value (exit-value node)))
(when value
(derive-node-type node (continuation-derived-type value)))))
;;; Try to join with a successor block. If we succeed, we return true,
;;; otherwise false.
-;;;
-;;; We cannot combine with a successor block if:
-;;; 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.
-;;;
-;;; Joining is easy when the successor's START continuation is the
-;;; same from our LAST's CONT. If they differ, then we can still join
-;;; when the last continuation has no next and the next continuation
-;;; has no uses. In this case, we replace the next continuation with
-;;; the last before joining the blocks.
(defun join-successor-if-possible (block)
(declare (type cblock block))
(let ((next (first (block-succ block))))
(let* ((last (block-last block))
(last-cont (node-cont last))
(next-cont (block-start next)))
- (cond ((or (rest (block-pred next))
- (not (eq (continuation-use last-cont) last))
- (eq next block)
- (not (eq (block-end-cleanup block)
- (block-start-cleanup next)))
- (not (eq (block-home-lambda block)
- (block-home-lambda next))))
+ (cond (;; We cannot combine with a successor block if:
+ (or
+ ;; The successor has more than one predecessor.
+ (rest (block-pred next))
+ ;; The last node's CONT is also used somewhere else.
+ (not (eq (continuation-use last-cont) last))
+ ;; The successor is the current block (infinite loop).
+ (eq next block)
+ ;; The next block has a different cleanup, and thus
+ ;; we may want to insert cleanup code between the
+ ;; two blocks at some point.
+ (not (eq (block-end-cleanup block)
+ (block-start-cleanup next)))
+ ;; The next block has a different home lambda, and
+ ;; thus the control transfer is a non-local exit.
+ (not (eq (block-home-lambda block)
+ (block-home-lambda next))))
nil)
+ ;; Joining is easy when the successor's START
+ ;; continuation is the same from our LAST's CONT.
((eq last-cont next-cont)
(join-blocks block next)
t)
+ ;; If they differ, then we can still join when the last
+ ;; continuation has no next and the next continuation
+ ;; has no uses.
((and (null (block-start-uses next))
(eq (continuation-kind last-cont) :inside-block))
+ ;; In this case, we replace the next
+ ;; continuation with the last before joining the blocks.
(let ((next-node (continuation-next next-cont)))
;; If NEXT-CONT does have a dest, it must be
- ;; unreachable, since there are no uses.
+ ;; unreachable, since there are no USES.
;; DELETE-CONTINUATION will mark the dest block as
;; DELETE-P [and also this block, unless it is no
;; longer backward reachable from the dest block.]
(values))
-;;; Delete any nodes in BLOCK whose value is unused and have no
-;;; side-effects. We can delete sets of lexical variables when the set
+;;; Delete any nodes in BLOCK whose value is unused and which have no
+;;; side effects. We can delete sets of lexical variables when the set
;;; variable has no references.
-;;;
-;;; [### For now, don't delete potentially flushable calls when they
-;;; have the CALL attribute. Someday we should look at the functional
-;;; args to determine if they have any side-effects.]
(defun flush-dead-code (block)
(declare (type cblock block))
(do-nodes-backwards (node cont block)
(when (fun-info-p info)
(let ((attr (fun-info-attributes info)))
(when (and (ir1-attributep attr flushable)
+ ;; ### For now, don't delete potentially
+ ;; flushable calls when they have the CALL
+ ;; attribute. Someday we should look at the
+ ;; functional args to determine if they have
+ ;; any side effects.
(not (ir1-attributep attr call)))
(flush-dest (combination-fun node))
(dolist (arg (combination-args node))
;;; 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
+;;; -- 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
+;;; -- 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
;; cross-compiler can't fold it because the
;; cross-compiler doesn't know how to evaluate it.
#+sb-xc-host
- (let* ((ref (continuation-use (combination-fun node)))
- (fun-name (leaf-source-name (ref-leaf ref))))
- (fboundp fun-name)))
+ (fboundp (combination-fun-source-name node)))
(constant-fold-call node)
(return-from ir1-optimize-combination)))
(transform-call call
`(lambda ,dummies
(,(leaf-source-name leaf)
- ,@dummies)))))))))))
+ ,@dummies))
+ (leaf-source-name leaf))))))))))
(values))
\f
;;;; known function optimization
(valid-fun-use node type :strict-result t))
(multiple-value-bind (severity args)
(catch 'give-up-ir1-transform
- (transform-call node (funcall fun node))
+ (transform-call node
+ (funcall fun node)
+ (combination-fun-source-name node))
(values :none nil))
(ecase severity
(:none
(setf (component-reoptimize (block-component block)) t)))))))
reoptimize))
-
;;; Take the lambda-expression RES, IR1 convert it in the proper
;;; environment, and then install it as the function for the call
;;; NODE. We do local call analysis so that the new function is
;;; integrated into the control flow.
-(defun transform-call (node res)
+;;;
+;;; We require the original function source name in order to generate
+;;; a meaningful debug name for the lambda we set up. (It'd be
+;;; possible to do this starting from debug names as well as source
+;;; names, but as of sbcl-0.7.1.5, there was no need for this
+;;; generality, since source names are always known to our callers.)
+(defun transform-call (node res source-name)
(declare (type combination node) (list res))
+ (aver (and (legal-fun-name-p source-name)
+ (not (eql source-name '.anonymous.))))
(with-ir1-environment-from-node node
(let ((new-fun (ir1-convert-inline-lambda
res
- :debug-name "something inlined in TRANSFORM-CALL"))
- (ref (continuation-use (combination-fun node))))
- (change-ref-leaf ref new-fun)
- (setf (combination-kind node) :full)
- (locall-analyze-component *current-component*)))
+ :debug-name (debug-namify "LAMBDA-inlined ~A"
+ (as-debug-name
+ source-name
+ "<unknown function>"))))
+ (ref (continuation-use (combination-fun node))))
+ (change-ref-leaf ref new-fun)
+ (setf (combination-kind node) :full)
+ (locall-analyze-component *current-component*)))
(values))
;;; Replace a call to a foldable function of constant arguments with
;;; call a :ERROR call.
;;;
;;; If there is more than one value, then we transform the call into a
-;;; values form.
+;;; VALUES form.
(defun constant-fold-call (call)
- (declare (type combination call))
- (let* ((args (mapcar #'continuation-value (combination-args call)))
- (ref (continuation-use (combination-fun call)))
- (fun-name (leaf-source-name (ref-leaf ref))))
-
+ (let ((args (mapcar #'continuation-value (combination-args call)))
+ (fun-name (combination-fun-source-name call)))
(multiple-value-bind (values win)
(careful-call fun-name args call "constant folding")
(if (not win)
- (setf (combination-kind call) :error)
- (let ((dummies (make-gensym-list (length args))))
- (transform-call
- call
- `(lambda ,dummies
- (declare (ignore ,@dummies))
- (values ,@(mapcar (lambda (x) `',x) values))))))))
-
+ (setf (combination-kind call) :error)
+ (let ((dummies (make-gensym-list (length args))))
+ (transform-call
+ call
+ `(lambda ,dummies
+ (declare (ignore ,@dummies))
+ (values ,@(mapcar (lambda (x) `',x) values)))
+ fun-name)))))
(values))
\f
;;;; local call optimization
;;; -- 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
-;;; let it be flushed as dead code. A side-effect of this substitution
+;;; 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)
(declare (type continuation arg) (type lambda-var var))
;;; any unreferenced variables. Note that FLUSH-DEAD-CODE will come
;;; along right away and delete the REF and then the lambda, since we
;;; flush the FUN continuation.
-(defun delete-let (fun)
- (declare (type clambda fun))
- (aver (member (functional-kind fun) '(:let :mv-let)))
- (note-unreferenced-vars fun)
- (let ((call (let-combination fun)))
+(defun delete-let (clambda)
+ (declare (type clambda clambda))
+ (aver (functional-letlike-p clambda))
+ (note-unreferenced-vars clambda)
+ (let ((call (let-combination clambda)))
(flush-dest (basic-combination-fun call))
(unlink-node call)
- (unlink-node (lambda-bind fun))
- (setf (lambda-bind fun) nil))
+ (unlink-node (lambda-bind clambda))
+ (setf (lambda-bind clambda) nil))
(values))
;;; This function is called when one of the arguments to a LET
;;; predicate didn't exist.
;;;
;;; This predicate was added to fix bug 138 in SBCL. In some obscure
-;;; circumstances, it was possible for a *FREE-FUNS* to contain a
+;;; circumstances, it was possible for a *FREE-FUNS* entry to contain a
;;; DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object contained IR1
;;; stuff (NODEs, BLOCKs...) referring to an already compiled (aka
;;; "dead") component. When this IR1 stuff was reused in a new
;; (sbcl-0.pre7.118) is this one:
(and (defined-fun-p free-fun)
(let ((functional (defined-fun-functional free-fun)))
- (and (lambda-p functional)
- (or
- ;; (The main reason for this first test is to bail out
- ;; early in cases where the LAMBDA-COMPONENT call in
- ;; the second test would fail because links it needs
- ;; are uninitialized or invalid.)
- ;;
- ;; If the BIND node for this LAMBDA is null, then
- ;; according to the slot comments, the LAMBDA has been
- ;; deleted or its call has been deleted. In that case,
- ;; it seems rather questionable to reuse it, and
- ;; certainly it shouldn't be necessary to reuse it, so
- ;; we cheerfully declare it invalid.
- (null (lambda-bind functional))
- ;; If this IR1 stuff belongs to a dead component, then
- ;; we can't reuse it without getting into bizarre
- ;; confusion.
- (eql (component-info (lambda-component functional)) :dead))))))
+ (or (and functional
+ (eql (functional-kind functional) :deleted))
+ (and (lambda-p functional)
+ (or
+ ;; (The main reason for this first test is to bail
+ ;; out early in cases where the LAMBDA-COMPONENT
+ ;; call in the second test would fail because links
+ ;; it needs are uninitialized or invalid.)
+ ;;
+ ;; If the BIND node for this LAMBDA is null, then
+ ;; according to the slot comments, the LAMBDA has
+ ;; been deleted or its call has been deleted. In
+ ;; that case, it seems rather questionable to reuse
+ ;; it, and certainly it shouldn't be necessary to
+ ;; reuse it, so we cheerfully declare it invalid.
+ (null (lambda-bind functional))
+ ;; If this IR1 stuff belongs to a dead component,
+ ;; then we can't reuse it without getting into
+ ;; bizarre confusion.
+ (eql (component-info (lambda-component functional))
+ :dead)))))))
;;; If NAME already has a valid entry in *FREE-FUNS*, then return
;;; the value. Otherwise, make a new GLOBAL-VAR using information from
(use-continuation res cont)))
(values)))
-;;; Add FUN to the COMPONENT-REANALYZE-FUNS, unless it's some trivial
-;;; type for which reanalysis is a trivial no-op, or unless it doesn't
-;;; belong in this component at all.
+;;; Add FUNCTIONAL to the COMPONENT-REANALYZE-FUNCTIONALS, unless it's
+;;; some trivial type for which reanalysis is a trivial no-op, or
+;;; unless it doesn't belong in this component at all.
;;;
-;;; FUN is returned.
-(defun maybe-reanalyze-fun (fun)
- (declare (type functional fun))
+;;; FUNCTIONAL is returned.
+(defun maybe-reanalyze-functional (functional)
+ (aver (not (eql (functional-kind functional) :deleted))) ; bug 148
(aver-live-component *current-component*)
- ;; When FUN is of a type for which reanalysis isn't a trivial no-op
- (when (typep fun '(or optional-dispatch clambda))
+ ;; When FUNCTIONAL is of a type for which reanalysis isn't a trivial
+ ;; no-op
+ (when (typep functional '(or optional-dispatch clambda))
- ;; When FUN knows its component
- (when (lambda-p fun)
- (aver (eql (lambda-component fun) *current-component*)))
+ ;; When FUNCTIONAL knows its component
+ (when (lambda-p functional)
+ (aver (eql (lambda-component functional) *current-component*)))
- (pushnew fun (component-reanalyze-funs *current-component*)))
+ (pushnew functional
+ (component-reanalyze-functionals *current-component*)))
- fun)
+ functional)
;;; Generate a REF node for LEAF, frobbing the LEAF structure as
;;; needed. If LEAF represents a defined function which has already
(let* ((leaf (or (and (defined-fun-p leaf)
(not (eq (defined-fun-inlinep leaf)
:notinline))
- (let ((fun (defined-fun-functional leaf)))
- (when (and fun (not (functional-kind fun)))
- (maybe-reanalyze-fun fun))))
+ (let ((functional (defined-fun-functional leaf)))
+ (when (and functional
+ (not (functional-kind functional)))
+ (maybe-reanalyze-functional functional))))
leaf))
(res (make-ref (or (lexenv-find leaf type-restrictions)
(leaf-type leaf))
(setf (continuation-%type-check fun-cont) nil)))
(values))
-;;; Convert a call to a local function. If the function has already
-;;; been LET converted, then throw FUN to LOCAL-CALL-LOSSAGE. This
-;;; should only happen when we are converting inline expansions for
-;;; local functions during optimization.
-(defun ir1-convert-local-combination (start cont form fun)
- (if (functional-kind fun)
- (throw 'local-call-lossage fun)
- (ir1-convert-combination start cont form
- (maybe-reanalyze-fun fun))))
+;;; Convert a call to a local function, or if the function has already
+;;; been LET converted, then throw FUNCTIONAL to
+;;; LOCALL-ALREADY-LET-CONVERTED. The THROW should only happen when we
+;;; are converting inline expansions for local functions during
+;;; optimization.
+(defun ir1-convert-local-combination (start cont form functional)
+
+ ;; The test here is for "when LET converted", as a translation of
+ ;; the old CMU CL comments into code. Unfortunately, the old CMU CL
+ ;; comments aren't specific enough to tell whether the correct
+ ;; translation is FUNCTIONAL-SOMEWHAT-LETLIKE-P or
+ ;; FUNCTIONAL-LETLIKE-P or what. The old CMU CL code assumed that
+ ;; any non-null FUNCTIONAL-KIND meant that the function "had been
+ ;; LET converted", which might even be right, but seems fragile, so
+ ;; we try to be pickier.
+ (when (or
+ ;; looks LET-converted
+ (functional-somewhat-letlike-p functional)
+ ;; It's possible for a LET-converted function to end up
+ ;; deleted later. In that case, for the purposes of this
+ ;; analysis, it is LET-converted: LET-converted functionals
+ ;; are too badly trashed to expand them inline, and deleted
+ ;; LET-converted functionals are even worse.
+ (eql (functional-kind functional) :deleted))
+ (throw 'locall-already-let-converted functional))
+ ;; Any other non-NIL KIND value is a case we haven't found a
+ ;; justification for, and at least some such values (e.g. :EXTERNAL
+ ;; and :TOPLEVEL) seem obviously wrong.
+ (aver (null (functional-kind functional)))
+
+ (ir1-convert-combination start
+ cont
+ form
+ (maybe-reanalyze-functional functional)))
\f
;;;; PROCESS-DECLS
(setf found (cdr var)))))
found))
-;;; Called by Process-Decls to deal with a variable type declaration.
-;;; If a lambda-var being bound, we intersect the type with the vars
-;;; type, otherwise we add a type-restriction on the var. If a symbol
+;;; Called by PROCESS-DECLS to deal with a variable type declaration.
+;;; If a LAMBDA-VAR being bound, we intersect the type with the var's
+;;; type, otherwise we add a type restriction on the var. If a symbol
;;; macro, we just wrap a THE around the expansion.
(defun process-type-decl (decl res vars)
(declare (list decl vars) (type lexenv res))
;;; Create a lambda node out of some code, returning the result. The
;;; bindings are specified by the list of VAR structures VARS. We deal
;;; with adding the names to the LEXENV-VARS for the conversion. The
-;;; result is added to the NEW-FUNS in the *CURRENT-COMPONENT* and
-;;; linked to the component head and tail.
+;;; result is added to the NEW-FUNCTIONALS in the *CURRENT-COMPONENT*
+;;; and linked to the component head and tail.
;;;
;;; We detect special bindings here, replacing the original VAR in the
;;; lambda list with a temporary variable. We then pass a list of the
(link-blocks block (component-tail *current-component*))))))
(link-blocks (component-head *current-component*) (node-block bind))
- (push lambda (component-new-funs *current-component*))
+ (push lambda (component-new-functionals *current-component*))
lambda))
:aux-vars (append (bind-vars) aux-vars)
:aux-vals (append (bind-vals) aux-vals)
:result cont
- :debug-name (debug-namify "varargs entry point for ~A"
+ :debug-name (debug-namify "varargs entry for ~A"
(as-debug-name source-name
debug-name))))
(last-entry (convert-optional-entry main-entry default-vars
:%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*))
+ (push res (component-new-functionals *current-component*))
(ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals
cont source-name debug-name)
(setf (optional-dispatch-min-args res) min)
(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)
+ (setf (block-next new-block) next
+ (block-prev new-block) head
+ (block-prev next) new-block
+ (block-next head) new-block
+ (continuation-block cont) new-block
+ (continuation-use cont) nil
+ (continuation-kind cont) :block-start)
new-block))
(:block-start
(continuation-block cont))))
(values))
;;; Add BLOCK to the next/prev chain following AFTER. We also set the
-;;; Component to be the same as for AFTER.
+;;; COMPONENT to be the same as for AFTER.
(defun add-to-dfo (block after)
(declare (type cblock block after))
(let ((next (block-next after))
\f
;;;; deleting stuff
-;;; Deal with deleting the last (read) reference to a LAMBDA-VAR. We
-;;; iterate over all local calls flushing the corresponding argument,
-;;; allowing the computation of the argument to be deleted. We also
-;;; mark the let for reoptimization, since it may be that we have
-;;; deleted the last variable.
-;;;
-;;; The LAMBDA-VAR may still have some SETs, but this doesn't cause
-;;; too much difficulty, since we can efficiently implement write-only
-;;; variables. We iterate over the sets, marking their blocks for dead
-;;; code flushing, since we can delete sets whose value is unused.
+;;; Deal with deleting the last (read) reference to a LAMBDA-VAR.
(defun delete-lambda-var (leaf)
(declare (type lambda-var leaf))
+
+ ;; Iterate over all local calls flushing the corresponding argument,
+ ;; allowing the computation of the argument to be deleted. We also
+ ;; mark the LET for reoptimization, since it may be that we have
+ ;; deleted its last variable.
(let* ((fun (lambda-var-home leaf))
(n (position leaf (lambda-vars fun))))
(dolist (ref (leaf-refs fun))
(flush-dest arg)
(setf (elt args n) nil))))))
+ ;; The LAMBDA-VAR may still have some SETs, but this doesn't cause
+ ;; too much difficulty, since we can efficiently implement
+ ;; write-only variables. We iterate over the SETs, marking their
+ ;; blocks for dead code flushing, since we can delete SETs whose
+ ;; value is unused.
(dolist (set (lambda-var-sets leaf))
(setf (block-flush-p (node-block set)) t))
(values))
-;;; Note that something interesting has happened to VAR. We only deal
-;;; with LET variables, marking the corresponding initial value arg as
-;;; needing to be reoptimized.
+;;; Note that something interesting has happened to VAR.
(defun reoptimize-lambda-var (var)
(declare (type lambda-var var))
(let ((fun (lambda-var-home var)))
+ ;; We only deal with LET variables, marking the corresponding
+ ;; initial value arg as needing to be reoptimized.
(when (and (eq (functional-kind fun) :let)
(leaf-refs var))
(do ((args (basic-combination-args
(clambda (delete-lambda fun)))
(values))
-;;; Deal with deleting the last reference to a LAMBDA. Since there is
-;;; only one way into a LAMBDA, deleting the last reference to a
-;;; LAMBDA ensures that there is no way to reach any of the code in
+;;; Deal with deleting the last reference to a CLAMBDA. Since there is
+;;; only one way into a CLAMBDA, deleting the last reference to a
+;;; CLAMBDA ensures that there is no way to reach any of the code in
;;; it. So we just set the FUNCTIONAL-KIND for FUN and its LETs to
;;; :DELETED, causing IR1 optimization to delete blocks in that
-;;; lambda.
-;;;
-;;; If the function isn't a LET, we unlink the function head and tail
-;;; from the component head and tail to indicate that the code is
-;;; unreachable. We also delete the function from COMPONENT-LAMBDAS
-;;; (it won't be there before local call analysis, but no matter.) If
-;;; the lambda was never referenced, we give a note.
-;;;
-;;; If the lambda is an XEP, then we null out the ENTRY-FUN in its
-;;; ENTRY-FUN so that people will know that it is not an entry point
-;;; anymore.
-(defun delete-lambda (leaf)
- (declare (type clambda leaf))
- (let ((kind (functional-kind leaf))
- (bind (lambda-bind leaf)))
- (aver (not (member kind '(:deleted :optional :toplevel))))
- (aver (not (functional-has-external-references-p leaf)))
- (setf (functional-kind leaf) :deleted)
- (setf (lambda-bind leaf) nil)
- (dolist (let (lambda-lets leaf))
+;;; CLAMBDA.
+(defun delete-lambda (clambda)
+ (declare (type clambda clambda))
+ (let ((original-kind (functional-kind clambda))
+ (bind (lambda-bind clambda)))
+ (aver (not (member original-kind '(:deleted :optional :toplevel))))
+ (aver (not (functional-has-external-references-p clambda)))
+ (setf (functional-kind clambda) :deleted)
+ (setf (lambda-bind clambda) nil)
+ (dolist (let (lambda-lets clambda))
(setf (lambda-bind let) nil)
(setf (functional-kind let) :deleted))
- (if (member kind '(:let :mv-let :assignment))
- (let ((home (lambda-home leaf)))
- (setf (lambda-lets home) (delete leaf (lambda-lets home))))
+ ;; (The IF test is (FUNCTIONAL-SOMEWHAT-LETLIKE-P CLAMBDA), except
+ ;; that we're using the old value of the KIND slot, not the
+ ;; current slot value, which has now been set to :DELETED.)
+ (if (member original-kind '(:let :mv-let :assignment))
+ (let ((home (lambda-home clambda)))
+ (setf (lambda-lets home) (delete clambda (lambda-lets home))))
+ ;; If the function isn't a LET, we unlink the function head
+ ;; and tail from the component head and tail to indicate that
+ ;; the code is unreachable. We also delete the function from
+ ;; COMPONENT-LAMBDAS (it won't be there before local call
+ ;; analysis, but no matter.) If the lambda was never
+ ;; referenced, we give a note.
(let* ((bind-block (node-block bind))
(component (block-component bind-block))
- (return (lambda-return leaf)))
- (aver (null (leaf-refs leaf)))
- (unless (leaf-ever-used leaf)
+ (return (lambda-return clambda)))
+ (aver (null (leaf-refs clambda)))
+ (unless (leaf-ever-used clambda)
(let ((*compiler-error-context* bind))
(compiler-note "deleting unused function~:[.~;~:*~% ~S~]"
- (leaf-debug-name leaf))))
+ (leaf-debug-name clambda))))
(unlink-blocks (component-head component) bind-block)
(when return
(unlink-blocks (node-block return) (component-tail component)))
(setf (component-reanalyze component) t)
- (let ((tails (lambda-tail-set leaf)))
+ (let ((tails (lambda-tail-set clambda)))
(setf (tail-set-funs tails)
- (delete leaf (tail-set-funs tails)))
- (setf (lambda-tail-set leaf) nil))
+ (delete clambda (tail-set-funs tails)))
+ (setf (lambda-tail-set clambda) nil))
(setf (component-lambdas component)
- (delete leaf (component-lambdas component)))))
+ (delete clambda (component-lambdas component)))))
- (when (eq kind :external)
- (let ((fun (functional-entry-fun leaf)))
+ ;; If the lambda is an XEP, then we null out the ENTRY-FUN in its
+ ;; ENTRY-FUN so that people will know that it is not an entry
+ ;; point anymore.
+ (when (eq original-kind :external)
+ (let ((fun (functional-entry-fun clambda)))
(setf (functional-entry-fun fun) nil)
(when (optional-dispatch-p fun)
(delete-optional-dispatch fun)))))
;;; entry-points, making them be normal lambdas, and then deleting the
;;; ones with no references. This deletes any e-p lambdas that were
;;; either never referenced, or couldn't be deleted when the last
-;;; deference was deleted (due to their :OPTIONAL kind.)
+;;; reference was deleted (due to their :OPTIONAL kind.)
;;;
-;;; Note that the last optional ep may alias the main entry, so when
-;;; we process the main entry, its kind may have been changed to NIL
-;;; or even converted to a let.
+;;; Note that the last optional entry point may alias the main entry,
+;;; so when we process the main entry, its KIND may have been changed
+;;; to NIL or even converted to a LETlike value.
(defun delete-optional-dispatch (leaf)
(declare (type optional-dispatch leaf))
(let ((entry (functional-entry-fun leaf)))
(clambda
(ecase (functional-kind leaf)
((nil :let :mv-let :assignment :escape :cleanup)
- (aver (not (functional-entry-fun leaf)))
+ (aver (null (functional-entry-fun leaf)))
(delete-lambda leaf))
(:external
(delete-lambda leaf))
;;; containing uses of CONT and set COMPONENT-REOPTIMIZE. If the PREV
;;; of the use is deleted, then we blow off reoptimization.
;;;
-;;; If the continuation is :Deleted, then we don't do anything, since
+;;; If the continuation is :DELETED, then we don't do anything, since
;;; all semantics have already been flushed. :DELETED-BLOCK-START
;;; start continuations are treated just like :BLOCK-START; it is
;;; possible that the continuation may be given a new dest (e.g. by
;; Guards COMBINATION-LAMBDA agains the REF being deleted.
(continuation-use (basic-combination-fun node)))
(let ((fun (combination-lambda node)))
- ;; If our REF was the 2'nd to last ref, and has been deleted, then
- ;; Fun may be a LET for some other combination.
- (when (and (member (functional-kind fun) '(:let :mv-let))
+ ;; If our REF was the second-to-last ref, and has been
+ ;; deleted, then FUN may be a LET for some other
+ ;; combination.
+ (when (and (functional-letlike-p fun)
(eq (let-combination fun) node))
(delete-lambda fun))))
(flush-dest (basic-combination-fun node))
(bind
(let ((lambda (bind-lambda node)))
(unless (eq (functional-kind lambda) :deleted)
- (aver (member (functional-kind lambda) '(:let :mv-let :assignment)))
+ (aver (functional-somewhat-letlike-p lambda))
(delete-lambda lambda))))
(exit
(let ((value (exit-value node))
;;; triggered by deletion.
(defun delete-component (component)
(declare (type component component))
- (aver (null (component-new-funs component)))
+ (aver (null (component-new-functionals component)))
(setf (component-kind component) :deleted)
(do-blocks (block component)
(setf (block-delete-p block) t))
nil))
nil)))
+;;; Return the source name of a combination. (This is an idiom
+;;; which was used in CMU CL. I gather it always works. -- WHN)
+(defun combination-fun-source-name (combination)
+ (let ((ref (continuation-use (combination-fun combination))))
+ (leaf-source-name (ref-leaf ref))))
+
;;; Return the COMBINATION node that is the call to the LET FUN.
(defun let-combination (fun)
(declare (type clambda fun))
- (aver (member (functional-kind fun) '(:let :mv-let)))
+ (aver (functional-letlike-p fun))
(continuation-dest (node-cont (first (leaf-refs fun)))))
;;; Return the initial value continuation for a LET variable, or NIL
(move-continuation-result node block locs cont))
(values))
-;;; Emit code to load a function object implementing FUN into
+;;; some sanity checks for a CLAMBDA passed to IR2-CONVERT-CLOSURE
+(defun assertions-on-ir2-converted-clambda (clambda)
+ ;; This assertion was sort of an experiment. It would be nice and
+ ;; sane and easier to understand things if it were *always* true,
+ ;; but experimentally I observe that it's only *almost* always
+ ;; true. -- WHN 2001-01-02
+ #+nil
+ (aver (eql (lambda-component clambda)
+ (block-component (ir2-block-block ir2-block))))
+ ;; Check for some weirdness which came up in bug
+ ;; 138, 2002-01-02.
+ ;;
+ ;; The MAKE-LOAD-TIME-CONSTANT-TN call above puts an :ENTRY record
+ ;; into the IR2-COMPONENT-CONSTANTS table. The dump-a-COMPONENT
+ ;; code
+ ;; * treats every HANDLEless :ENTRY record into a
+ ;; patch, and
+ ;; * expects every patch to correspond to an
+ ;; IR2-COMPONENT-ENTRIES record.
+ ;; The IR2-COMPONENT-ENTRIES records are set by ENTRY-ANALYZE
+ ;; walking over COMPONENT-LAMBDAS. Bug 138b arose because there
+ ;; was a HANDLEless :ENTRY record which didn't correspond to an
+ ;; IR2-COMPONENT-ENTRIES record. That problem is hard to debug
+ ;; when it's caught at dump time, so this assertion tries to catch
+ ;; it here.
+ (aver (member clambda
+ (component-lambdas (lambda-component clambda))))
+ ;; another bug-138-related issue: COMPONENT-NEW-FUNCTIONALS is
+ ;; used as a queue for stuff pending to do in IR1, and now that
+ ;; we're doing IR2 it should've been completely flushed (but
+ ;; wasn't).
+ (aver (null (component-new-functionals (lambda-component clambda))))
+ (values))
+
+;;; Emit code to load a function object implementing FUNCTIONAL into
;;; RES. This gets interesting when the referenced function is a
;;; closure: we must make the closure and move the closed-over values
;;; into it.
;;;
-;;; FUN is either a :TOPLEVEL-XEP functional or the XEP lambda for the
-;;; called function, since local call analysis converts all closure
-;;; references. If a :TOPLEVEL-XEP, we know it is not a closure.
+;;; FUNCTIONAL is either a :TOPLEVEL-XEP functional or the XEP lambda
+;;; for the called function, since local call analysis converts all
+;;; closure references. If a :TOPLEVEL-XEP, we know it is not a
+;;; closure.
;;;
;;; If a closed-over LAMBDA-VAR has no refs (is deleted), then we
;;; don't initialize that slot. This can happen with closures over
;;; top level variables, where optimization of the closure deleted the
;;; variable. Since we committed to the closure format when we
;;; pre-analyzed the top level code, we just leave an empty slot.
-(defun ir2-convert-closure (ref ir2-block fun res)
- (declare (type ref ref) (type ir2-block ir2-block)
- (type functional fun) (type tn res))
-
- (unless (leaf-info fun)
- (setf (leaf-info fun)
- (make-entry-info :name (functional-debug-name fun))))
- (let ((entry (make-load-time-constant-tn :entry fun))
- (closure (etypecase fun
+(defun ir2-convert-closure (ref ir2-block functional res)
+ (declare (type ref ref)
+ (type ir2-block ir2-block)
+ (type functional functional)
+ (type tn res))
+ (aver (not (eql (functional-kind functional) :deleted)))
+ (unless (leaf-info functional)
+ (setf (leaf-info functional)
+ (make-entry-info :name (functional-debug-name functional))))
+ (let ((entry (make-load-time-constant-tn :entry functional))
+ (closure (etypecase functional
(clambda
-
- ;; This assertion was sort of an experiment. It
- ;; would be nice and sane and easier to understand
- ;; things if it were *always* true, but
- ;; experimentally I observe that it's only
- ;; *almost* always true. -- WHN 2001-01-02
- #+nil
- (aver (eql (lambda-component fun)
- (block-component (ir2-block-block ir2-block))))
-
- ;; Check for some weirdness which came up in bug
- ;; 138, 2002-01-02.
- ;;
- ;; The MAKE-LOAD-TIME-CONSTANT-TN call above puts
- ;; an :ENTRY record into the
- ;; IR2-COMPONENT-CONSTANTS table. The
- ;; dump-a-COMPONENT code
- ;; * treats every HANDLEless :ENTRY record into a
- ;; patch, and
- ;; * expects every patch to correspond to an
- ;; IR2-COMPONENT-ENTRIES record.
- ;; The IR2-COMPONENT-ENTRIES records are set by
- ;; ENTRY-ANALYZE walking over COMPONENT-LAMBDAS.
- ;; Bug 138b arose because there was a HANDLEless
- ;; :ENTRY record which didn't correspond to an
- ;; IR2-COMPONENT-ENTRIES record. That problem is
- ;; hard to debug when it's caught at dump time, so
- ;; this assertion tries to catch it here.
- (aver (member fun
- (component-lambdas (lambda-component fun))))
-
- ;; another bug-138-related issue: COMPONENT-NEW-FUNS
- ;; is an IR1 temporary, and now that we're doing IR2
- ;; it should've been completely flushed (but wasn't).
- (aver (null (component-new-funs (lambda-component fun))))
-
- (physenv-closure (get-lambda-physenv fun)))
+ (assertions-on-ir2-converted-clambda functional)
+ (physenv-closure (get-lambda-physenv functional)))
(functional
- (aver (eq (functional-kind fun) :toplevel-xep))
+ (aver (eq (functional-kind functional) :toplevel-xep))
nil))))
(cond (closure
\f
;;;; multiple values
-;;; This is almost identical to IR2-Convert-Let. Since LTN annotates
+;;; This is almost identical to IR2-CONVERT-LET. Since LTN annotates
;;; the continuation for the correct number of values (with the
;;; continuation user responsible for defaulting), we can just pick
;;; them up from the continuation.
\f
;;;; non-local exit
-;;; Convert a non-local lexical exit. First find the NLX-Info in our
+;;; Convert a non-local lexical exit. First find the NLX-INFO in our
;;; environment. Note that this is never called on the escape exits
;;; for CATCH and UNWIND-PROTECT, since the escape functions aren't
;;; IR2 converted.
(move-continuation-result node block () (node-cont node))
(values))
-;;; Emit code to set up a non-local exit. INFO is the NLX-Info for the
+;;; Emit code to set up a non-local exit. INFO is the NLX-INFO for the
;;; exit, and TAG is the continuation for the catch tag (if any.) We
;;; get at the target PC by passing in the label to the vop. The vop
;;; is responsible for building a return-PC object.
;;;; This file contains stuff for maintaining a database of special
;;;; information about functions known to the compiler. This includes
-;;;; semantic information such as side-effects and type inference
+;;;; semantic information such as side effects and type inference
;;;; functions as well as transforms and IR2 translators.
;;;; This software is part of the SBCL system. See the README file for
;;; IR1 boolean function attributes
;;;
-;;; There are a number of boolean attributes of known functions which we like
-;;; to have in IR1. This information is mostly side effect information of a
-;;; sort, but it is different from the kind of information we want in IR2. We
-;;; aren't interested in a fine breakdown of side effects, since we do very
-;;; little code motion on IR1. We are interested in some deeper semantic
-;;; properties such as whether it is safe to pass stack closures to.
+;;; There are a number of boolean attributes of known functions which
+;;; we like to have in IR1. This information is mostly side effect
+;;; information of a sort, but it is different from the kind of
+;;; information we want in IR2. We aren't interested in a fine
+;;; breakdown of side effects, since we do very little code motion on
+;;; IR1. We are interested in some deeper semantic properties such as
+;;; whether it is safe to pass stack closures to.
(def-boolean-attribute ir1
- ;; May call functions that are passed as arguments. In order to determine
- ;; what other effects are present, we must find the effects of all arguments
- ;; that may be functions.
+ ;; may call functions that are passed as arguments. In order to
+ ;; determine what other effects are present, we must find the
+ ;; effects of all arguments that may be functions.
call
- ;; May incorporate function or number arguments into the result or somehow
- ;; pass them upward. Note that this applies to any argument that *might* be
- ;; a function or number, not just the arguments that always are.
+ ;; may incorporate function or number arguments into the result or
+ ;; somehow pass them upward. Note that this applies to any argument
+ ;; that *might* be a function or number, not just the arguments that
+ ;; always are.
unsafe
- ;; May fail to return during correct execution. Errors are O.K.
+ ;; may fail to return during correct execution. Errors are O.K.
unwind
- ;; The (default) worst case. Includes all the other bad things, plus any
- ;; other possible bad thing. If this is present, the above bad attributes
- ;; will be explicitly present as well.
+ ;; the (default) worst case. Includes all the other bad things, plus
+ ;; any other possible bad thing. If this is present, the above bad
+ ;; attributes will be explicitly present as well.
any
- ;; May be constant-folded. The function has no side effects, but may be
- ;; affected by side effects on the arguments. e.g. SVREF, MAPC. Functions
- ;; that side-effect their arguments are not considered to be foldable.
- ;; Although it would be "legal" to constant fold them (since it "is an error"
- ;; to modify a constant), we choose not to mark these functions as foldable
- ;; in this database.
+ ;; may be constant-folded. The function has no side effects, but may
+ ;; be affected by side effects on the arguments. e.g. SVREF, MAPC.
+ ;; Functions that side-effect their arguments are not considered to
+ ;; be foldable. Although it would be "legal" to constant fold them
+ ;; (since it "is an error" to modify a constant), we choose not to
+ ;; mark these functions as foldable in this database.
foldable
- ;; May be eliminated if value is unused. The function has no side effects
- ;; except possibly CONS. If a function is defined to signal errors, then it
- ;; is not flushable even if it is movable or foldable.
+ ;; may be eliminated if value is unused. The function has no side
+ ;; effects except possibly CONS. If a function is defined to signal
+ ;; errors, then it is not flushable even if it is movable or
+ ;; foldable.
flushable
- ;; May be moved with impunity. Has no side effects except possibly CONS, and
- ;; is affected only by its arguments.
+ ;; may be moved with impunity. Has no side effects except possibly
+ ;; consing, and is affected only by its arguments.
movable
- ;; Function is a true predicate likely to be open-coded. Convert any
- ;; non-conditional uses into (IF <pred> T NIL).
+ ;; The function is a true predicate likely to be open-coded. Convert
+ ;; any non-conditional uses into (IF <pred> T NIL).
predicate
- ;; Inhibit any warning for compiling a recursive definition. (Normally the
- ;; compiler warns when compiling a recursive definition for a known function,
- ;; since it might be a botched interpreter stub.)
+ ;; Inhibit any warning for compiling a recursive definition.
+ ;; (Normally the compiler warns when compiling a recursive
+ ;; definition for a known function, since it might be a botched
+ ;; interpreter stub.)
recursive
- ;; Function does explicit argument type checking, so the declared type should
- ;; not be asserted when a definition is compiled.
+ ;; The function does explicit argument type checking, so the
+ ;; declared type should not be asserted when a definition is
+ ;; compiled.
explicit-check)
(defstruct (fun-info #-sb-xc-host (:pure t))
- ;; Boolean attributes of this function.
+ ;; boolean attributes of this function.
(attributes (missing-arg) :type attributes)
- ;; A list of Transform structures describing transforms for this function.
+ ;; TRANSFORM structures describing transforms for this function
(transforms () :type list)
- ;; A function which computes the derived type for a call to this function by
- ;; examining the arguments. This is null when there is no special method for
- ;; this function.
+ ;; a function which computes the derived type for a call to this
+ ;; function by examining the arguments. This is null when there is
+ ;; no special method for this function.
(derive-type nil :type (or function null))
- ;; A function that does various unspecified code transformations by directly
- ;; hacking the IR. Returns true if further optimizations of the call
- ;; shouldn't be attempted.
+ ;; a function that does various unspecified code transformations by
+ ;; directly hacking the IR. Returns true if further optimizations of
+ ;; the call shouldn't be attempted.
;;
- ;; KLUDGE: This return convention (non-NIL if you shouldn't do further
- ;; optimiz'ns) is backwards from the return convention for transforms.
- ;; -- WHN 19990917
+ ;; KLUDGE: This return convention (non-NIL if you shouldn't do
+ ;; further optimiz'ns) is backwards from the return convention for
+ ;; transforms. -- WHN 19990917
(optimizer nil :type (or function null))
- ;; If true, a special-case LTN annotation method that is used in place of the
- ;; standard type/policy template selection. It may use arbitrary code to
- ;; choose a template, decide to do a full call, or conspire with the
- ;; IR2-Convert method to do almost anything. The Combination node is passed
- ;; as the argument.
+ ;; If true, a special-case LTN annotation method that is used in
+ ;; place of the standard type/policy template selection. It may use
+ ;; arbitrary code to choose a template, decide to do a full call, or
+ ;; conspire with the IR2-Convert method to do almost anything. The
+ ;; Combination node is passed as the argument.
(ltn-annotate nil :type (or function null))
- ;; If true, the special-case IR2 conversion method for this function. This
- ;; deals with funny functions, and anything else that can't be handled using
- ;; the template mechanism. The Combination node and the IR2-Block are passed
- ;; as arguments.
+ ;; If true, the special-case IR2 conversion method for this
+ ;; function. This deals with funny functions, and anything else that
+ ;; can't be handled using the template mechanism. The Combination
+ ;; node and the IR2-Block are passed as arguments.
(ir2-convert nil :type (or function null))
- ;; A list of all the templates that could be used to translate this function
+ ;; all the templates that could be used to translate this function
;; into IR2, sorted by increasing cost.
(templates nil :type list)
- ;; If non-null, then this function is a unary type predicate for this type.
+ ;; If non-null, then this function is a unary type predicate for
+ ;; this type.
(predicate-type nil :type (or ctype null))
- ;; If non-null, use this function to annotate the known call for the byte
- ;; compiler. If it returns NIL, then change the call to :full.
+ ;; If non-null, use this function to annotate the known call for the
+ ;; byte compiler. If it returns NIL, then change the call to :full.
(byte-annotate nil :type (or function null)))
(defprinter (fun-info)
;; sbcl-0.pre7.54 or so, that's inconsistent with being a
;; FUN-TYPE.)
(type (missing-arg) :type ctype)
- ;; the transformation function. Takes the COMBINATION node and returns a
- ;; lambda, or throws out.
+ ;; the transformation function. Takes the COMBINATION node and
+ ;; returns a lambda expression, or throws out.
(function (missing-arg) :type function)
;; string used in efficiency notes
(note (missing-arg) :type string)
(when cont (continuation-type cont))))
;;; Derive the result type according to the float contagion rules, but
-;;; always return a float. This is used for irrational functions that preserve
-;;; realness of their arguments.
+;;; always return a float. This is used for irrational functions that
+;;; preserve realness of their arguments.
(defun result-type-float-contagion (call)
(declare (type combination call))
(reduce #'numeric-contagion (combination-args call)
:key #'continuation-type
:initial-value (specifier-type 'single-float)))
-;;; Return a closure usable as a derive-type method for accessing the N'th
-;;; argument. If arg is a list, result is a list. If arg is a vector, result
-;;; is a vector with the same element type.
+;;; Return a closure usable as a derive-type method for accessing the
+;;; N'th argument. If arg is a list, result is a list. If arg is a
+;;; vector, result is a vector with the same element type.
(defun sequence-result-nth-arg (n)
(lambda (call)
(declare (type combination call))
;;;; this code can't appear in the build sequence until after
;;;; SB!XC:DEFMACRO has been defined, and so this stuff is separated
;;;; out of the main compiler/macros.lisp file (which has to appear
-;;;; earlier)
+;;;; earlier).
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(in-package "SB!C")
+;;; Def-Boolean-Attribute Name Attribute-Name*
+;;;
+;;; Define a new class of Boolean attributes, with the attributes
+;;; having the specified ATTRIBUTE-NAMES. NAME is the name of the
+;;; class, which is used to generate some macros to manipulate sets of
+;;; the attributes:
+;;;
+;;; NAME-attributep attributes attribute-name*
+;;; Return true if any of the named attributes are present, false
+;;; otherwise. When set with SETF, updates the place Attributes
+;;; setting or clearing the specified attributes.
+;;;
+;;; NAME-attributes attribute-name*
+;;; Return a set of the named attributes.
#+sb-xc-host
(sb!xc:defmacro def-boolean-attribute (name &rest attribute-names)
- #!+sb-doc
- "Def-Boolean-Attribute Name Attribute-Name*
- Define a new class of boolean attributes, with the attributes having the
- specified Attribute-Names. Name is the name of the class, which is used to
- generate some macros to manipulate sets of the attributes:
-
- NAME-attributep attributes attribute-name*
- Return true if one of the named attributes is present, false otherwise.
- When set with SETF, updates the place Attributes setting or clearing the
- specified attributes.
-
- NAME-attributes attribute-name*
- Return a set of the named attributes."
-
(let ((translations-name (symbolicate "*" name "-ATTRIBUTE-TRANSLATIONS*"))
(test-name (symbolicate name "-ATTRIBUTEP")))
(collect ((alist))
(defparameter ,translations-name ',(alist)))
(defmacro ,test-name (attributes &rest attribute-names)
- "Automagically generated boolean attribute test function. See
- Def-Boolean-Attribute."
+ "Automagically generated Boolean attribute test function. See
+ DEF-BOOLEAN-ATTRIBUTE."
`(logtest ,(compute-attribute-mask attribute-names
,translations-name)
(the attributes ,attributes)))
(define-setf-expander ,test-name (place &rest attributes
&environment env)
- "Automagically generated boolean attribute setter. See
- Def-Boolean-Attribute."
+ "Automagically generated Boolean attribute setter. See
+ DEF-BOOLEAN-ATTRIBUTE."
(boolean-attribute-setter--target place
attributes
env
',test-name))
(defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
- "Automagically generated boolean attribute creation function. See
- Def-Boolean-Attribute."
+ "Automagically generated Boolean attribute creation function. See
+ DEF-BOOLEAN-ATTRIBUTE."
(compute-attribute-mask attribute-names ,translations-name))))))
;;; a helper function for the cross-compilation target Lisp code which
(,next ,n-current)))))
(values)))))
+;;; Push ITEM onto a list linked by the accessor function NEXT that is
+;;; stored in PLACE.
#+sb-xc-host
(sb!xc:defmacro push-in (next item place &environment env)
- #!+sb-doc
- "Push Item onto a list linked by the accessor function Next that is stored in
- Place."
(multiple-value-bind (temps vals stores store access)
(sb!xc:get-setf-expansion place env)
(when (cdr stores)
;;; reference to a TN, even when the TN is already known to be global.
;;;
;;; When we see reference to global TNs during the scan, we add the
-;;; global-conflict as :Read-Only, since we don't know the correct kind until
+;;; global-conflict as :READ-ONLY, since we don't know the correct kind until
;;; we are done scanning the block.
(defun find-local-references (block)
(declare (type ir2-block block))
(setf (ir2-block-local-tn-count block) ltn-num)))
nil)
-;;; Finish up the global conflicts for TNs referenced in Block according to
-;;; the local Kill and Live sets.
+;;; Finish up the global conflicts for TNs referenced in BLOCK
+;;; according to the local Kill and Live sets.
;;;
-;;; We set the kind for TNs already in the global-TNs. If not written at
-;;; all, then is :Read-Only, the default. Must have been referenced somehow,
-;;; or we wouldn't have conflicts for it.
+;;; We set the kind for TNs already in the global-TNs. If not written
+;;; at all, then is :READ-ONLY, the default. Must have been referenced
+;;; somehow, or we wouldn't have conflicts for it.
;;;
-;;; We also iterate over all the local TNs, looking for TNs local to this
-;;; block that are still live at the block beginning, and thus must be global.
-;;; This case is only important when a TN is read in a block but not written in
-;;; any other, since otherwise the write would promote the TN to global. But
-;;; this does happen with various passing-location TNs that are magically
-;;; written. This also serves to propagate the lives of erroneously
-;;; uninitialized TNs so that consistency checks can detect them.
+;;; We also iterate over all the local TNs, looking for TNs local to
+;;; this block that are still live at the block beginning, and thus
+;;; must be global. This case is only important when a TN is read in a
+;;; block but not written in any other, since otherwise the write
+;;; would promote the TN to global. But this does happen with various
+;;; passing-location TNs that are magically written. This also serves
+;;; to propagate the lives of erroneously uninitialized TNs so that
+;;; consistency checks can detect them.
(defun init-global-conflict-kind (block)
(declare (type ir2-block block))
(let ((live (ir2-block-live-out block)))
;;; causing the subsequent reanalysis to think that the TN has already been
;;; seen in that block.
;;;
-;;; This function must not be called on blocks that have :More TNs.
+;;; This function must not be called on blocks that have :MORE TNs.
(defun clear-lifetime-info (block)
(declare (type ir2-block block))
(setf (ir2-block-local-tn-count block) 0)
(values))
-;;; This provides a panic mode for assigning LTN numbers when there is a VOP
-;;; with so many more operands that they can't all be assigned distinct
-;;; numbers. When this happens, we recover by assigning all the more operands
-;;; the same LTN number. We can get away with this, since all more args (and
-;;; results) are referenced simultaneously as far as conflict analysis is
-;;; concerned.
+;;; This provides a panic mode for assigning LTN numbers when there is
+;;; a VOP with so many more operands that they can't all be assigned
+;;; distinct numbers. When this happens, we recover by assigning all
+;;; the &MORE operands the same LTN number. We can get away with this,
+;;; since all &MORE args (and results) are referenced simultaneously
+;;; as far as conflict analysis is concerned.
;;;
-;;; Block is the IR2-Block that the more VOP is at the end of. Ops is the
-;;; full argument or result TN-Ref list. Fixed is the types of the fixed
-;;; operands (used only to skip those operands.)
+;;; BLOCK is the IR2-Block that the more VOP is at the end of. Ops is
+;;; the full argument or result TN-Ref list. Fixed is the types of the
+;;; fixed operands (used only to skip those operands.)
;;;
-;;; What we do is grab a LTN number, then make a :Read-Only global conflict
-;;; for each more operand TN. We require that there be no existing global
-;;; conflict in Block for any of the operands. Since conflicts must be cleared
-;;; before the first call, this only prohibits the same TN being used both as a
-;;; more operand and as any other operand to the same VOP.
+;;; What we do is grab a LTN number, then make a :READ-ONLY global
+;;; conflict for each more operand TN. We require that there be no
+;;; existing global conflict in BLOCK for any of the operands. Since
+;;; conflicts must be cleared before the first call, this only
+;;; prohibits the same TN being used both as a more operand and as any
+;;; other operand to the same VOP.
;;;
-;;; We don't have to worry about getting the correct conflict kind, since
-;;; Init-Global-Conflict-Kind will fix things up. Similarly,
-;;; FIND-LOCAL-REFERENCES will set the local conflict bit corresponding to this
-;;; call.
+;;; We don't have to worry about getting the correct conflict kind,
+;;; since INIT-GLOBAL-CONFLICT-KIND will fix things up. Similarly,
+;;; FIND-LOCAL-REFERENCES will set the local conflict bit
+;;; corresponding to this call.
;;;
-;;; We also set the Local and Local-Number slots in each TN. It is
+;;; We also set the LOCAL and LOCAL-NUMBER slots in each TN. It is
;;; possible that there are no operands in any given call to this function, but
;;; there had better be either some more args or more results.
(defun coalesce-more-ltn-numbers (block ops fixed)
(defevent coalesce-more-ltn-numbers
"Coalesced LTN numbers for a more operand to meet Local-TN-Limit.")
-;;; Loop over the blocks in Component, assigning LTN numbers and recording
-;;; TN birth and death. The only interesting action is when we run out of
-;;; local TN numbers while finding local references.
+;;; Loop over the blocks in COMPONENT, assigning LTN numbers and
+;;; recording TN birth and death. The only interesting action is when
+;;; we run out of local TN numbers while finding local references.
;;;
-;;; If we run out of LTN numbers while processing a VOP within the block,
-;;; then we just split off the VOPs we have successfully processed into their
-;;; own block.
+;;; If we run out of LTN numbers while processing a VOP within the
+;;; block, then we just split off the VOPs we have successfully
+;;; processed into their own block.
;;;
-;;; If we run out of LTN numbers while processing the our first VOP (the
-;;; last in the block), then it must be the case that this VOP has large more
-;;; operands. We split the VOP into its own block, and then call
-;;; Coalesce-More-Ltn-Numbers to assign all the more args/results the same LTN
-;;; number(s).
+;;; If we run out of LTN numbers while processing the our first VOP
+;;; (the last in the block), then it must be the case that this VOP
+;;; has large more operands. We split the VOP into its own block, and
+;;; then call COALESCE-MORE-LTN-NUMBERS to assign all the more
+;;; args/results the same LTN number(s).
;;;
-;;; In either case, we clear the lifetime information that we computed so
-;;; far, recomputing it after taking corrective action.
+;;; In either case, we clear the lifetime information that we computed
+;;; so far, recomputing it after taking corrective action.
;;;
-;;; Whenever we split a block, we finish the pre-pass on the split-off block
-;;; by doing Find-Local-References and Init-Global-Conflict-Kind. This can't
-;;; run out of LTN numbers.
+;;; Whenever we split a block, we finish the pre-pass on the split-off
+;;; block by doing FIND-LOCAL-REFERENCES and
+;;; INIT-GLOBAL-CONFLICT-KIND. This can't run out of LTN numbers.
(defun lifetime-pre-pass (component)
(declare (type component component))
(let ((counter -1))
(values live-bits live-list))
-;;; Return as values, a LTN bit-vector and a list (threaded by TN-Next*)
-;;; representing the TNs live at the end of Block (exclusive of :Live TNs).
+;;; Return as values, a LTN bit-vector and a list (threaded by
+;;; TN-Next*) representing the TNs live at the end of Block (exclusive
+;;; of :LIVE TNs).
;;;
-;;; We iterate over the TNs in the global conflicts that are live at the block
-;;; end, setting up the TN-Local-Conflicts and TN-Local-Number, and adding the
-;;; TN to the live list.
+;;; We iterate over the TNs in the global conflicts that are live at
+;;; the block end, setting up the TN-LOCAL-CONFLICTS and
+;;; TN-LOCAL-NUMBER, and adding the TN to the live list.
;;;
;;; If a :MORE result is not live, we effectively fake a read to it. This is
;;; part of the action described in ENSURE-RESULTS-LIVE.
;;; discover an XEP after the initial local call analyze pass.
(defun make-xep (fun)
(declare (type functional fun))
- (aver (not (functional-entry-fun fun)))
+ (aver (null (functional-entry-fun 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
(values))
-;;; We examine all NEW-FUNS in COMPONENT, attempting to convert calls
-;;; into local calls when it is legal. We also attempt to convert each
-;;; LAMBDA to a LET. LET conversion is also triggered by deletion of a
-;;; function reference, but functions that start out eligible for
-;;; conversion must be noticed sometime.
+;;; We examine all NEW-FUNCTIONALS in COMPONENT, attempting to convert
+;;; calls into local calls when it is legal. We also attempt to
+;;; convert each LAMBDA to a LET. LET conversion is also triggered by
+;;; deletion of a function reference, but functions that start out
+;;; eligible for conversion must be noticed sometime.
;;;
;;; Note that there is a lot of action going on behind the scenes
;;; here, triggered by reference deletion. In particular, the
;;; COMPONENT-LAMBDAS are being hacked to remove newly deleted and LET
;;; converted LAMBDAs, so it is important that the LAMBDA is added to
-;;; the COMPONENT-LAMBDAS when it is. Also, the COMPONENT-NEW-FUNS may
-;;; contain all sorts of drivel, since it is not updated when we
-;;; delete functions, etc. Only COMPONENT-LAMBDAS is updated.
+;;; the COMPONENT-LAMBDAS when it is. Also, the
+;;; COMPONENT-NEW-FUNCTIONALS may contain all sorts of drivel, since
+;;; it is not updated when we delete functions, etc. Only
+;;; COMPONENT-LAMBDAS is updated.
;;;
-;;; COMPONENT-REANALYZE-FUNS is treated similarly to
-;;; NEW-FUNS, but we don't add lambdas to the LAMBDAS.
+;;; COMPONENT-REANALYZE-FUNCTIONALS is treated similarly to
+;;; COMPONENT-NEW-FUNCTIONALS, 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)))))
- (unless fun (return))
- (let ((kind (functional-kind fun)))
- (cond ((member kind '(:deleted :let :mv-let :assignment)))
- ((and (null (leaf-refs fun)) (eq kind nil)
- (not (functional-entry-fun fun)))
- (delete-functional fun))
+ (let* ((new-functional (pop (component-new-functionals component)))
+ (functional (or new-functional
+ (pop (component-reanalyze-functionals component)))))
+ (unless functional
+ (return))
+ (let ((kind (functional-kind functional)))
+ (cond ((or (functional-somewhat-letlike-p functional)
+ (eql kind :deleted))
+ (values)) ; nothing to do
+ ((and (null (leaf-refs functional)) (eq kind nil)
+ (not (functional-entry-fun functional)))
+ (delete-functional functional))
(t
- ;; Fix/check FUN's relationship to COMPONENT-LAMDBAS.
- (cond ((not (lambda-p fun))
- ;; Since FUN isn't a LAMBDA, this doesn't apply: no-op.
+ ;; Fix/check FUNCTIONAL's relationship to COMPONENT-LAMDBAS.
+ (cond ((not (lambda-p functional))
+ ;; Since FUNCTIONAL isn't a LAMBDA, this doesn't
+ ;; apply: no-op.
(values))
- (new-fun ; FUN came from NEW-FUNS, hence is new.
- ;; FUN becomes part of COMPONENT-LAMBDAS now.
- (aver (not (member fun (component-lambdas component))))
- (push fun (component-lambdas component)))
- ;; FIXME: Maybe we don't need this clause?
- ;; The only time I really thought I needed it
- ;; was bug 138, and adding this clause didn't
- ;; fix bug 138 but instead caused all sorts
- ;; of other things to fail downstream...
- #|
- ((eql (lambda-inlinep fun) :inline)
- ;; FUNs marked :INLINE are sometimes in
- ;; COMPONENT-LAMBDAS and sometimes not. I (WHN
- ;; 2002-01-01) haven't figured this one out yet,
- ;; so don't assert anything.
- ;;
- ;; (One possibility: LAMBDAs to represent the
- ;; inline expansions of things which are defined
- ;; elsewhere might not be in COMPONENT-LAMBDAS,
- ;; which LAMBDAs to represent the inline
- ;; expansions of local functions might in
- ;; COMPONENT-LAMBDAS?)
- (values))
- |#
- (t ; FUN is old.
- ;; FUN should be in COMPONENT-LAMBDAS already.
- (aver (member fun (component-lambdas component)))))
- (locall-analyze-fun-1 fun)
- (when (lambda-p fun)
- (maybe-let-convert fun)))))))
+ (new-functional ; FUNCTIONAL came from
+ ; NEW-FUNCTIONALS, hence is new.
+ ;; FUNCTIONAL becomes part of COMPONENT-LAMBDAS now.
+ (aver (not (member functional
+ (component-lambdas component))))
+ (push functional (component-lambdas component)))
+ (t ; FUNCTIONAL is old.
+ ;; FUNCTIONAL should be in COMPONENT-LAMBDAS already.
+ (aver (member functional (component-lambdas
+ component)))))
+ (locall-analyze-fun-1 functional)
+ (when (lambda-p functional)
+ (maybe-let-convert functional)))))))
(values))
(defun locall-analyze-clambdas-until-done (clambdas)
;; COMPONENT is the only one here. Let's make that explicit.
(aver (= 1 (length (functional-components clambda))))
(aver (eql component (first (functional-components clambda))))
- (when (component-new-funs component)
+ (when (component-new-functionals component)
(setf did-something t)
(locall-analyze-component component))))
(unless did-something
;;; to be in an infinite recursive loop, then change the reference to
;;; reference a fresh copy. We return whichever function we decide to
;;; reference.
-(defun maybe-expand-local-inline (fun ref call)
+(defun maybe-expand-local-inline (original-functional ref call)
(if (and (policy call
- (and (>= speed space) (>= speed compilation-speed)))
+ (and (>= speed space)
+ (>= speed compilation-speed)))
(not (eq (functional-kind (node-home-lambda call)) :external))
(inline-expansion-ok call))
- (with-ir1-environment-from-node call
- (let* ((*lexenv* (functional-lexenv fun))
- (won nil)
- (res (catch 'local-call-lossage
- (prog1
- (ir1-convert-lambda
- (functional-inline-expansion fun)
- :debug-name (debug-namify "local inline ~A"
- (leaf-debug-name fun)))
- (setq won t)))))
- (cond (won
- (change-ref-leaf ref res)
- res)
- (t
- (let ((*compiler-error-context* call))
- (compiler-note "couldn't inline expand because expansion ~
- calls this LET-converted local function:~
- ~% ~S"
- (leaf-debug-name res)))
- fun))))
- fun))
+ (multiple-value-bind (losing-local-functional converted-lambda)
+ (catch 'locall-already-let-converted
+ (with-ir1-environment-from-node call
+ (let ((*lexenv* (functional-lexenv original-functional)))
+ (values nil
+ (ir1-convert-lambda
+ (functional-inline-expansion original-functional)
+ :debug-name (debug-namify
+ "local inline ~A"
+ (leaf-debug-name
+ original-functional)))))))
+ (cond (losing-local-functional
+ (let ((*compiler-error-context* call))
+ (compiler-note "couldn't inline expand because expansion ~
+ calls this LET-converted local function:~
+ ~% ~S"
+ (leaf-debug-name losing-local-functional)))
+ original-functional)
+ (t
+ (change-ref-leaf ref converted-lambda)
+ converted-lambda)))
+ original-functional))
;;; Dispatch to the appropriate function to attempt to convert a call.
;;; REF must be a reference to a FUNCTIONAL. This is called in IR1
(link-blocks block (lambda-block fun))
(values t (maybe-convert-to-assignment fun))))))
-;;; This is called when we believe it might make sense to convert Fun
-;;; to an assignment. All this function really does is determine when
-;;; a function with more than one call can still be combined with the
-;;; calling function's environment. We can convert when:
+;;; This is called when we believe it might make sense to convert
+;;; CLAMBDA to an assignment. All this function really does is
+;;; determine when a function with more than one call can still be
+;;; combined with the calling function's environment. We can convert
+;;; when:
;;; -- The function is a normal, non-entry function, and
;;; -- Except for one call, all calls must be tail recursive calls
;;; in the called function (i.e. are self-recursive tail calls)
;;; calls as long as they all return to the same place (i.e. have the
;;; same conceptual continuation.) A special case of this would be
;;; when all of the outside calls are tail recursive.
-(defun maybe-convert-to-assignment (fun)
- (declare (type clambda fun))
- (when (and (not (functional-kind fun))
- (not (functional-entry-fun fun)))
+(defun maybe-convert-to-assignment (clambda)
+ (declare (type clambda clambda))
+ (when (and (not (functional-kind clambda))
+ (not (functional-entry-fun clambda)))
(let ((non-tail nil)
(call-fun nil))
- (when (and (dolist (ref (leaf-refs fun) t)
+ (when (and (dolist (ref (leaf-refs clambda) t)
(let ((dest (continuation-dest (node-cont ref))))
(when (or (not dest)
(block-delete-p (node-block dest)))
(return nil))
(let ((home (node-home-lambda ref)))
- (unless (eq home fun)
- (when call-fun (return nil))
+ (unless (eq home clambda)
+ (when call-fun
+ (return nil))
(setq call-fun home))
(unless (node-tail-p dest)
- (when (or non-tail (eq home fun)) (return nil))
+ (when (or non-tail (eq home clambda))
+ (return nil))
(setq non-tail dest)))))
- (ok-initial-convert-p fun))
- (setf (functional-kind fun) :assignment)
- (let-convert fun (or non-tail
- (continuation-dest
- (node-cont (first (leaf-refs fun))))))
- (when non-tail (reoptimize-call non-tail))
+ (ok-initial-convert-p clambda))
+ (setf (functional-kind clambda) :assignment)
+ (let-convert clambda
+ (or non-tail
+ (continuation-dest
+ (node-cont (first (leaf-refs clambda))))))
+ (when non-tail
+ (reoptimize-call non-tail))
t))))
(declare (special *constraint-number* *delayed-ir1-transforms*))
(loop
(ir1-optimize-until-done component)
- (when (or (component-new-funs component)
- (component-reanalyze-funs component))
+ (when (or (component-new-functionals component)
+ (component-reanalyze-functionals component))
(maybe-mumble "locall ")
(locall-analyze-component component))
(dfo-as-needed component)
(flet ((want-reoptimization-p ()
(or (component-reoptimize component)
(component-reanalyze component)
- (component-new-funs component)
- (component-reanalyze-funs component))))
+ (component-new-functionals component)
+ (component-reanalyze-functionals component))))
(unless (and (want-reoptimization-p)
;; We delay the generation of type checks until
;; the type constraints have had time to
\f
;;;; trace output
-;;; Print out some useful info about Component to Stream.
+;;; Print out some useful info about COMPONENT to STREAM.
(defun describe-component (component *standard-output*)
(declare (type component component))
(format t "~|~%;;;; component: ~S~2%" (component-name component))
;;;; the error context and for recovering from errors.
;;;;
;;;; The interface we provide to this stuff is the stream-oid
-;;;; Source-Info structure. The bookkeeping is done as a side-effect
+;;;; SOURCE-INFO structure. The bookkeeping is done as a side effect
;;;; of getting the next source form.
;;; A FILE-INFO structure holds all the source information for a
;;; small, non-negative integer that is used as an alias. The following
;;; keywords are defined:
;;;
-;;; :Element-Size Size
-;;; The size of objects in this SC in whatever units the SB uses. This
-;;; defaults to 1.
+;;; :ELEMENT-SIZE Size
+;;; The size of objects in this SC in whatever units the SB uses.
+;;; This defaults to 1.
;;;
-;;; :Alignment Size
-;;; The alignment restrictions for this SC. TNs will only be allocated at
-;;; offsets that are an even multiple of this number. Defaults to 1.
+;;; :ALIGNMENT Size
+;;; The alignment restrictions for this SC. TNs will only be
+;;; allocated at offsets that are an even multiple of this number.
+;;; This defaults to 1.
;;;
-;;; :Locations (Location*)
-;;; If the SB is :Finite, then this is a list of the offsets within the SB
-;;; that are in this SC.
+;;; :LOCATIONS (Location*)
+;;; If the SB is :FINITE, then this is a list of the offsets within
+;;; the SB that are in this SC.
;;;
-;;; :Reserve-Locations (Location*)
+;;; :RESERVE-LOCATIONS (Location*)
;;; A subset of the Locations that the register allocator should try to
;;; reserve for operand loading (instead of to hold variable values.)
;;;
-;;; :Save-P {T | NIL}
+;;; :SAVE-P {T | NIL}
;;; If T, then values stored in this SC must be saved in one of the
-;;; non-save-p :Alternate-SCs across calls.
+;;; non-save-p :ALTERNATE-SCs across calls.
;;;
-;;; :Alternate-SCs (SC*)
+;;; :ALTERNATE-SCS (SC*)
;;; Indicates other SCs that can be used to hold values from this SC across
;;; calls or when storage in this SC is exhausted. The SCs should be
;;; specified in order of decreasing \"goodness\". There must be at least
;;; one SC in an unbounded SB, unless this SC is only used for restricted or
;;; wired TNs.
;;;
-;;; :Constant-SCs (SC*)
+;;; :CONSTANT-SCS (SC*)
;;; A list of the names of all the constant SCs that can be loaded into this
;;; SC by a move function.
(defmacro define-storage-class (name number sb-name &key (element-size '1)
(defparameter *primitive-type-slot-alist*
'((:check . primitive-type-check)))
+;;; Primitive-Type-VOP Vop (Kind*) Type*
+;;;
+;;; Annotate all the specified primitive Types with the named VOP
+;;; under each of the specified kinds:
+;;;
+;;; :CHECK
+;;; A one-argument one-result VOP that moves the argument to the
+;;; result, checking that the value is of this type in the process.
(defmacro primitive-type-vop (vop kinds &rest types)
- #!+sb-doc
- "Primitive-Type-VOP Vop (Kind*) Type*
- Annotate all the specified primitive Types with the named VOP under each of
- the specified kinds:
-
- :Check
- A one argument one result VOP that moves the argument to the result,
- checking that the value is of this type in the process."
(let ((n-vop (gensym))
(n-type (gensym)))
`(let ((,n-vop (template-or-lose ',vop)))
types)
nil)))
-;;; Return true if SC is either one of Ptype's SC's, or one of those SC's
-;;; alternate or constant SCs.
+;;; Return true if SC is either one of PTYPE's SC's, or one of those
+;;; SC's alternate or constant SCs.
(defun meta-sc-allowed-by-primitive-type (sc ptype)
(declare (type sc sc) (type primitive-type ptype))
(let ((scn (sc-number sc)))
(effects '(any) :type list)
(affected '(any) :type list)
;; a list of the names of functions this VOP is a translation of and
- ;; the policy that allows this translation to be done. :Fast is a
+ ;; the policy that allows this translation to be done. :FAST is a
;; safe default, since it isn't a safe policy.
(translate () :type list)
(ltn-policy :fast :type ltn-policy)
;;; keyword indicating the interpretation of the other forms in the
;;; SPEC:
;;;
-;;; :Args {(Name {Key Value}*)}*
-;;; :Results {(Name {Key Value}*)}*
+;;; :ARGS {(Name {Key Value}*)}*
+;;; :RESULTS {(Name {Key Value}*)}*
;;; The Args and Results are specifications of the operand TNs passed
;;; to the VOP. If there is an inherited VOP, any unspecified options
;;; are defaulted from the inherited argument (or result) of the same
;;; necessary, guaranteeing that the operand is always one of the
;;; specified SCs.
;;;
-;;; :Load-TN Load-Name
-;;; Load-Name is bound to the load TN allocated for this operand,
-;;; or to NIL if no load TN was allocated.
+;;; :LOAD-TN Load-Name
+;;; Load-Name is bound to the load TN allocated for this
+;;; operand, or to NIL if no load TN was allocated.
;;;
-;;; :Load-If EXPRESSION
+;;; :LOAD-IF EXPRESSION
;;; Controls whether automatic operand loading is done.
;;; EXPRESSION is evaluated with the fixed operand TNs bound.
;;; If EXPRESSION is true,then loading is done and the variable
;;; loading is not done, and the variable is bound to the actual
;;; operand.
;;;
-;;; :More T-or-NIL
-;;; If specified, Name is bound to the TN-Ref for the first
+;;; :MORE T-or-NIL
+;;; If specified, NAME is bound to the TN-Ref for the first
;;; argument or result following the fixed arguments or results.
;;; A :MORE operand must appear last, and cannot be targeted or
;;; restricted.
;;;
-;;; :Target Operand
+;;; :TARGET Operand
;;; This operand is targeted to the named operand, indicating a
;;; desire to pack in the same location. Not legal for results.
;;;
-;;; :From Time-Spec
-;;; :To Time-Spec
+;;; :FROM Time-Spec
+;;; :TO Time-Spec
;;; Specify the beginning or end of the operand's lifetime.
;;; :FROM can only be used with results, and :TO only with
;;; arguments. The default for the N'th argument/result is
;;; (:ARGUMENT N)/(:RESULT N). These options are necessary
;;; primarily when operands are read or written out of order.
;;;
-;;; :Conditional
+;;; :CONDITIONAL
;;; This is used in place of :RESULTS with conditional branch VOPs.
;;; There are no result values: the result is a transfer of control.
;;; The target label is passed as the first :INFO arg. The second
;;; :INFO arg is true if the sense of the test should be negated.
-;;; A side-effect is to set the PREDICATE attribute for functions
+;;; A side effect is to set the PREDICATE attribute for functions
;;; in the :TRANSLATE option.
;;;
-;;; :Temporary ({Key Value}*) Name*
+;;; :TEMPORARY ({Key Value}*) Name*
;;; Allocate a temporary TN for each Name, binding that variable to
;;; the TN within the body of the generators. In addition to :TARGET
;;; (which is is the same as for operands), the following options are
;;; defined:
;;;
;;; :SC SC-Name
-;;; :Offset SB-Offset
-;;; Force the temporary to be allocated in the specified SC with the
-;;; specified offset. Offset is evaluated at macroexpand time. If
-;;; Offset is emitted, the register allocator chooses a free
-;;; location in SC. If both SC and Offset are omitted, then the
-;;; temporary is packed according to its primitive type.
+;;; :OFFSET SB-Offset
+;;; Force the temporary to be allocated in the specified SC
+;;; with the specified offset. Offset is evaluated at
+;;; macroexpand time. If Offset is emitted, the register
+;;; allocator chooses a free location in SC. If both SC and
+;;; Offset are omitted, then the temporary is packed according
+;;; to its primitive type.
;;;
-;;; :From Time-Spec
-;;; :To Time-Spec
-;;; Similar to the argument/result option, this specifies the start and
-;;; end of the temporaries' lives. The defaults are :Load and :Save,
-;;; i.e. the duration of the VOP. The other intervening phases are
-;;; :Argument,:Eval and :Result. Non-zero sub-phases can be specified
-;;; by a list, e.g. by default the second argument's life ends at
-;;; (:Argument 1).
+;;; :FROM Time-Spec
+;;; :TO Time-Spec
+;;; Similar to the argument/result option, this specifies the
+;;; start and end of the temporaries' lives. The defaults are
+;;; :LOAD and :SAVE, i.e. the duration of the VOP. The other
+;;; intervening phases are :ARGUMENT,:EVAL and :RESULT.
+;;; Non-zero sub-phases can be specified by a list, e.g. by
+;;; default the second argument's life ends at (:ARGUMENT 1).
;;;
-;;; :Generator Cost Form*
+;;; :GENERATOR Cost Form*
;;; Specifies the translation into assembly code. Cost is the
;;; estimated cost of the code emitted by this generator. The body
;;; is arbitrary Lisp code that emits the assembly language
;;; During the evaluation of the body, the names of the operands
;;; and temporaries are bound to the actual TNs.
;;;
-;;; :Effects Effect*
-;;; :Affected Effect*
+;;; :EFFECTS Effect*
+;;; :AFFECTED Effect*
;;; Specifies the side effects that this VOP has and the side
;;; effects that effect its execution. If unspecified, these
;;; default to the worst case.
;;;
-;;; :Info Name*
+;;; :INFO Name*
;;; Define some magic arguments that are passed directly to the code
;;; generator. The corresponding trailing arguments to VOP or
;;; %PRIMITIVE are stored in the VOP structure. Within the body
;;; of the generators, the named variables are bound to these
-;;; values. Except in the case of :Conditional VOPs, :Info arguments
+;;; values. Except in the case of :CONDITIONAL VOPs, :INFO arguments
;;; cannot be specified for VOPS that are the direct translation
-;;; for a function (specified by :Translate).
+;;; for a function (specified by :TRANSLATE).
;;;
-;;; :Ignore Name*
+;;; :IGNORE Name*
;;; Causes the named variables to be declared IGNORE in the
;;; generator body.
;;;
-;;; :Variant Thing*
-;;; :Variant-Vars Name*
+;;; :VARIANT Thing*
+;;; :VARIANT-VARS Name*
;;; These options provide a way to parameterize families of VOPs
-;;; that differ only trivially. :Variant makes the specified
+;;; that differ only trivially. :VARIANT makes the specified
;;; evaluated Things be the "variant" associated with this VOP.
;;; :VARIANT-VARS causes the named variables to be bound to the
;;; corresponding Things within the body of the generator.
;;;
-;;; :Variant-Cost Cost
+;;; :VARIANT-COST Cost
;;; Specifies the cost of this VOP, overriding the cost of any
;;; inherited generator.
;;;
-;;; :Note {String | NIL}
+;;; :NOTE {String | NIL}
;;; A short noun-like phrase describing what this VOP "does", i.e.
;;; the implementation strategy. If supplied, efficiency notes will
;;; be generated when type uncertainty prevents :TRANSLATE from
;;; working. NIL inhibits any efficiency note.
;;;
-;;; :Arg-Types {* | PType | (:OR PType*) | (:CONSTANT Type)}*
-;;; :Result-Types {* | PType | (:OR PType*)}*
-;;; Specify the template type restrictions used for automatic translation.
-;;; If there is a :More operand, the last type is the more type. :CONSTANT
-;;; specifies that the argument must be a compile-time constant of the
-;;; specified Lisp type. The constant values of :CONSTANT arguments are
-;;; passed as additional :INFO arguments rather than as :ARGS.
+;;; :ARG-TYPES {* | PType | (:OR PType*) | (:CONSTANT Type)}*
+;;; :RESULT-TYPES {* | PType | (:OR PType*)}*
+;;; Specify the template type restrictions used for automatic
+;;; translation. If there is a :MORE operand, the last type is the
+;;; more type. :CONSTANT specifies that the argument must be a
+;;; compile-time constant of the specified Lisp type. The constant
+;;; values of :CONSTANT arguments are passed as additional :INFO
+;;; arguments rather than as :ARGS.
;;;
-;;; :Translate Name*
+;;; :TRANSLATE Name*
;;; This option causes the VOP template to be entered as an IR2
;;; translation for the named functions.
;;;
-;;; :Policy {:Small | :Fast | :Safe | :Fast-Safe}
+;;; :POLICY {:SMALL | :FAST | :SAFE | :FAST-SAFE}
;;; Specifies the policy under which this VOP is the best translation.
;;;
-;;; :Guard Form
-;;; Specifies a Form that is evaluated in the global environment. If
-;;; form returns NIL, then emission of this VOP is prohibited even when
-;;; all other restrictions are met.
+;;; :GUARD Form
+;;; Specifies a Form that is evaluated in the global environment.
+;;; If form returns NIL, then emission of this VOP is prohibited
+;;; even when all other restrictions are met.
;;;
-;;; :VOP-Var Name
-;;; :Node-Var Name
+;;; :VOP-VAR Name
+;;; :NODE-VAR Name
;;; In the generator, bind the specified variable to the VOP or
;;; the Node that generated this VOP.
;;;
-;;; :Save-P {NIL | T | :Compute-Only | :Force-To-Stack}
+;;; :SAVE-P {NIL | T | :COMPUTE-ONLY | :FORCE-TO-STACK}
;;; Indicates how a VOP wants live registers saved.
;;;
-;;; :Move-Args {NIL | :Full-Call | :Local-Call | :Known-Return}
+;;; :MOVE-ARGS {NIL | :FULL-CALL | :LOCAL-CALL | :KNOWN-RETURN}
;;; Indicates if and how the more args should be moved into a
;;; different frame.
(def!macro define-vop ((name &optional inherits) &rest specs)
;;; Emit-Template Node Block Template Args Results [Info]
;;;
-;;; Call the emit function for Template, linking the result in at the
-;;; end of Block.
+;;; Call the emit function for TEMPLATE, linking the result in at the
+;;; end of BLOCK.
(defmacro emit-template (node block template args results &optional info)
(let ((n-first (gensym))
(n-last (gensym)))
;;; VOP Name Node Block Arg* Info* Result*
;;;
-;;; Emit the VOP (or other template) Name at the end of the IR2-Block
-;;; Block, using Node for the source context. The interpretation of
+;;; Emit the VOP (or other template) NAME at the end of the IR2-BLOCK
+;;; BLOCK, using NODE for the source context. The interpretation of
;;; the remaining arguments depends on the number of operands of
;;; various kinds that are declared in the template definition. VOP
;;; cannot be used for templates that have more-args or more-results,
;;; since the number of arguments and results is indeterminate for
;;; these templates. Use VOP* instead.
;;;
-;;; Args and Results are the TNs that are to be referenced by the
+;;; ARGS and RESULTS are the TNs that are to be referenced by the
;;; template as arguments and results. If the template has
-;;; codegen-info arguments, then the appropriate number of Info forms
-;;; following the Arguments are used for codegen info.
+;;; codegen-info arguments, then the appropriate number of INFO forms
+;;; following the arguments are used for codegen info.
(defmacro vop (name node block &rest operands)
(let* ((parse (vop-parse-or-lose name))
(arg-count (length (vop-parse-args parse)))
;;; arguments and results to the template. More-Args and More-Results
;;; are heads of TN-Ref lists that are added onto the end of the
;;; TN-Refs for the explicitly supplied operand TNs. The TN-Refs for
-;;; the more operands must have the TN and Write-P slots correctly
+;;; the more operands must have the TN and WRITE-P slots correctly
;;; initialized.
;;;
-;;; As with VOP, the Info forms are evaluated and passed as codegen
+;;; As with VOP, the INFO forms are evaluated and passed as codegen
;;; info arguments.
(defmacro vop* (name node block args results &rest info)
(declare (type cons args results))
(,n-bod ,tn-var))
(let ((,ltns (ir2-block-local-tns ,n-block)))
- ;; Do TNs always-live in this block and live :More TNs.
+ ;; Do TNs always-live in this block and live :MORE TNs.
(do ((,n-conf (ir2-block-global-tns ,n-block)
(global-conflicts-next ,n-conf)))
((null ,n-conf))
;;; Flags that are used to indicate various things about a block, such
;;; as what optimizations need to be done on it:
;;; -- REOPTIMIZE is set when something interesting happens the uses of a
-;;; continuation whose Dest is in this block. This indicates that the
+;;; continuation whose DEST is in this block. This indicates that the
;;; value-driven (forward) IR1 optimizations should be done on this block.
;;; -- FLUSH-P is set when code in this block becomes potentially flushable,
;;; usually due to a continuation's DEST becoming null.
;;
;; Note that logical associations between CLAMBDAs and COMPONENTs
;; seem to exist for a while before this is initialized. See e.g.
- ;; the NEW-FUNS slot. In particular, I got burned by writing some
- ;; code to use this value to decide which components need
+ ;; the NEW-FUNCTIONALS slot. In particular, I got burned by writing
+ ;; some code to use this value to decide which components need
;; LOCALL-ANALYZE-COMPONENT, when it turns out that
;; LOCALL-ANALYZE-COMPONENT had a role in initializing this value
;; (and DFO stuff does too, maybe). Also, even after it's
;; (possibly as LETs, or implicitly as XEPs if an OPTIONAL-DISPATCH.)
;; Between runs of local call analysis there may be some debris of
;; converted or even deleted functions in this list.
- (new-funs () :type list)
+ (new-functionals () :type list)
;; If this is true, then there is stuff in this component that could
;; benefit from further IR1 optimization.
(reoptimize t :type boolean)
;; 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).
+ ;; LAMBDAs onto my NEW-FUNCTIONALS, 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
;; arguments for the note, or the FUN-TYPE that would have
;; enabled the transformation but failed to match.
(failed-optimizations (make-hash-table :test 'eq) :type hash-table)
- ;; This is similar to NEW-FUNS, but is used when a function has
- ;; already been analyzed, but new references have been added by
- ;; inline expansion. Unlike NEW-FUNS, this is not disjoint from
- ;; COMPONENT-LAMBDAS.
- (reanalyze-funs nil :type list))
+ ;; This is similar to NEW-FUNCTIONALS, but is used when a function
+ ;; has already been analyzed, but new references have been added by
+ ;; inline expansion. Unlike NEW-FUNCTIONALS, this is not disjoint
+ ;; from COMPONENT-LAMBDAS.
+ (reanalyze-functionals nil :type list))
(defprinter (component :identity t)
name
#!+sb-show id
;;; Check that COMPONENT is suitable for roles which involve adding
;;; new code. (gotta love imperative programming with lotso in-place
-;;; side-effects...)
+;;; 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
type
(info :test info))
-;;; The NLX-Info structure is used to collect various information
-;;; about non-local exits. This is effectively an annotation on the
+;;; An NLX-INFO structure is used to collect various information about
+;;; non-local exits. This is effectively an annotation on the
;;; CONTINUATION, although it is accessed by searching in the
;;; PHYSENV-NLX-INFO.
(def!struct (nlx-info (:make-load-form-fun ignore-it))
;;
;; This slot is primarily an indication of where this exit delivers
;; its values to (if any), but it is also used as a sort of name to
- ;; allow us to find the NLX-Info that corresponds to a given exit.
- ;; For this purpose, the Entry must also be used to disambiguate,
+ ;; allow us to find the NLX-INFO that corresponds to a given exit.
+ ;; For this purpose, the ENTRY must also be used to disambiguate,
;; since exits to different places may deliver their result to the
;; same continuation.
(continuation (missing-arg) :type continuation)
;; the entry stub inserted by physical environment analysis. This is
- ;; a block containing a call to the %NLX-Entry funny function that
+ ;; a block containing a call to the %NLX-ENTRY funny function that
;; has the original exit destination as its successor. Null only
;; temporarily.
(target nil :type (or cblock null))
;; continuation for the call.
;;
;; :MV-LET
- ;; Similar to :LET, but the call is an MV-CALL.
+ ;; Similar to :LET (as per FUNCTIONAL-LETLIKE-P), but the call
+ ;; is an MV-CALL.
;;
;; :ASSIGNMENT
- ;; similar to a LET, but can have other than one call as long as
- ;; there is at most one non-tail call.
+ ;; similar to a LET (as per FUNCTIONAL-SOMEWHAT-LETLIKE-P), but
+ ;; can have other than one call as long as there is at most
+ ;; one non-tail call.
;;
;; :OPTIONAL
- ;; a lambda that is an entry-point for an optional-dispatch.
+ ;; a lambda that is an entry point for an OPTIONAL-DISPATCH.
;; Similar to NIL, but requires greater caution, since local call
;; analysis may create new references to this function. Also, the
;; function cannot be deleted even if it has *no* references. The
;;
;; With all other kinds, this is null.
(entry-fun nil :type (or functional null))
- ;; the value of any inline/notinline declaration for a local function
+ ;; the value of any inline/notinline declaration for a local
+ ;; function (or NIL in any case if no inline expansion is available)
(inlinep nil :type inlinep)
;; If we have a lambda that can be used as in inline expansion for
;; this function, then this is it. If there is no source-level
- ;; lambda corresponding to this function then this is Null (but then
+ ;; lambda corresponding to this function then this is null (but then
;; INLINEP will always be NIL as well.)
(inline-expansion nil :type list)
- ;; the lexical environment that the inline-expansion should be converted in
+ ;; the lexical environment that the INLINE-EXPANSION should be converted in
(lexenv *lexenv* :type lexenv)
;; the original function or macro lambda list, or :UNSPECIFIED if
;; this is a compiler created function
%debug-name
#!+sb-show id)
+;;; Is FUNCTIONAL LET-converted? (where we're indifferent to whether
+;;; it returns one value or multiple values)
+(defun functional-letlike-p (functional)
+ (member (functional-kind functional)
+ '(:let :mv-let)))
+
+;;; Is FUNCTIONAL sorta LET-converted? (where even an :ASSIGNMENT counts)
+;;;
+;;; FIXME: I (WHN) don't understand this one well enough to give a good
+;;; definition or even a good function name, it's just a literal copy
+;;; of a CMU CL idiom. Does anyone have a better name or explanation?
+(defun functional-somewhat-letlike-p (functional)
+ (or (functional-letlike-p functional)
+ (eql (functional-kind functional) :assignment)))
+
;;; FUNCTIONAL name operations
(defun functional-debug-name (functional)
;; FUNCTIONAL-%DEBUG-NAME takes precedence over FUNCTIONAL-SOURCE-NAME
;;;; lexical exits.
;;; The ENTRY node serves to mark the start of the dynamic extent of a
-;;; lexical exit. It is the mess-up node for the corresponding :Entry
+;;; lexical exit. It is the mess-up node for the corresponding :ENTRY
;;; cleanup.
(defstruct (entry (:include node)
(:copier nil))
(bit-ior (the local-tn-bit-vector (svref loc-confs num))
(tn-local-conflicts tn) t))))))))
-;;; Return the total number of IR2 blocks in Component.
+;;; Return the total number of IR2-BLOCKs in COMPONENT.
(defun ir2-block-count (component)
(declare (type component component))
(do ((2block (block-info (block-next (component-head component)))
(when (ir2-block-number 2block)
(return (1+ (ir2-block-number 2block))))))
-;;; Ensure that the conflicts vectors for each :Finite SB are large
+;;; Ensure that the conflicts vectors for each :FINITE SB are large
;;; enough for the number of blocks allocated. Also clear any old
;;; conflicts and reset the current size to the initial size.
(defun init-sb-vectors (component)
(setf (finite-sb-current-size sb) (sb-size sb))
(setf (finite-sb-last-offset sb) 0))))))
-;;; Expand the :Unbounded SB backing SC by either the initial size or
+;;; Expand the :UNBOUNDED SB backing SC by either the initial size or
;;; the SC element size, whichever is larger. If NEEDED-SIZE is
;;; larger, then use that size.
(defun grow-sc (sc &optional (needed-size 0))
(cond
(ptype
(aver (member (sc-number sc) (primitive-type-scs ptype)))
- (error "SC ~S doesn't have any :Unbounded alternate SCs, but is~@
+ (error "SC ~S doesn't have any :UNBOUNDED alternate SCs, but is~@
a SC for primitive-type ~S."
(sc-name sc) (primitive-type-name ptype)))
(t
- (error "SC ~S doesn't have any :Unbounded alternate SCs."
+ (error "SC ~S doesn't have any :UNBOUNDED alternate SCs."
(sc-name sc)))))))))
;;; Return a list of format arguments describing how TN is used in
;;; Pack a wired TN, checking that the offset is in bounds for the SB,
;;; and that the TN doesn't conflict with some other TN already packed
;;; in that location. If the TN is wired to a location beyond the end
-;;; of a :Unbounded SB, then grow the SB enough to hold the TN.
+;;; of a :UNBOUNDED SB, then grow the SB enough to hold the TN.
;;;
;;; ### Checking for conflicts is disabled for :SPECIFIED-SAVE TNs.
;;; This is kind of a hack to make specifying wired stack save
(declare (type component component))
(aver (every (lambda (x)
(eq (functional-kind x) :deleted))
- (component-new-funs component)))
- (setf (component-new-funs component) ())
- (dolist (fun (component-lambdas component))
- (reinit-lambda-physenv fun))
+ (component-new-functionals component)))
+ (setf (component-new-functionals component) ())
+ (dolist (clambda (component-lambdas component))
+ (reinit-lambda-physenv clambda))
(mapc #'add-lambda-vars-and-let-vars-to-closures
(component-lambdas component))
;;;
;;; If a CATCH or an UNWIND-protect, then we set the LEXENV for the
;;; last node in the cleanup code to be the enclosing environment, to
-;;; represent the fact that the binding was undone as a side-effect of
+;;; represent the fact that the binding was undone as a side effect of
;;; the exit. This will cause a lexical exit to be broken up if we are
;;; actually exiting the scope (i.e. a BLOCK), and will also do any
;;; other cleanups that may have to be done on the way.
;;; EXIT into ENV. This is called for each non-local exit node, of
;;; which there may be several per exit continuation. This is what we
;;; do:
-;;; -- If there isn't any NLX-Info entry in the environment, make
+;;; -- If there isn't any NLX-INFO entry in the environment, make
;;; an entry stub, otherwise just move the exit block link to
;;; the component tail.
;;; -- Close over the NLX-INFO in the exit environment.
;;; FIXME: Doing this is slightly flaky (since we can't do it right
;;; without all the headaches of true code walking), and it shouldn't
;;; be necessary with modern Python anyway, as long as POLICY-QUALITY
-;;; is properly DEFKNOWNed to have no side-effects so that it can be
+;;; is properly DEFKNOWNed to have no side effects so that it can be
;;; optimized away if unused. So this should probably go away.
(defun policy-qualities-used-by (expr)
(let ((result nil))
;; A form that returns the current value. This may be set with SETF to set
;; the current value.
(current (error "Must specify CURRENT."))
- ;; In a :Normal iterator, a form that tests whether there is a current value.
+ ;; In a :NORMAL iterator, a form that tests whether there is a current value.
(done nil)
- ;; In a :Result iterator, a form that truncates the result at the current
+ ;; In a :RESULT iterator, a form that truncates the result at the current
;; position and returns it.
(result nil)
;; A form that returns the initial total number of values. The result is
(in-package "SB!C")
\f
-;;; Scan through Block looking for uses of :Unknown continuations that have
-;;; their Dest outside of the block. We do some checking to verify the
-;;; invariant that all pushes come after the last pop.
+;;; Scan through BLOCK looking for uses of :UNKNOWN continuations that
+;;; have their DEST outside of the block. We do some checking to
+;;; verify the invariant that all pushes come after the last pop.
(defun find-pushed-continuations (block)
(let* ((2block (block-info block))
(popped (ir2-block-popped 2block))
;;;; stack analysis
;;; Return a list of all the blocks containing genuine uses of one of the
-;;; Receivers. Exits are excluded, since they don't drop through to the
+;;; RECEIVERS. Exits are excluded, since they don't drop through to the
;;; receiver.
(defun find-values-generators (receivers)
(declare (list receivers))
(res (node-block use))))))
(res)))
-;;; Analyze the use of unknown-values continuations in Component, inserting
-;;; cleanup code to discard values that are generated but never received. This
-;;; phase doesn't need to be run when Values-Receivers is null, i.e. there are
-;;; no unknown-values continuations used across block boundaries.
+;;; Analyze the use of unknown-values continuations in COMPONENT,
+;;; inserting cleanup code to discard values that are generated but
+;;; never received. This phase doesn't need to be run when
+;;; Values-Receivers is null, i.e. there are no unknown-values
+;;; continuations used across block boundaries.
;;;
-;;; Do the backward graph walk, starting at each values receiver. We ignore
-;;; receivers that already have a non-null Start-Stack. These are nested
-;;; values receivers that have already been reached on another walk. We don't
-;;; want to clobber that result with our null initial stack.
+;;; Do the backward graph walk, starting at each values receiver. We
+;;; ignore receivers that already have a non-null START-STACK. These
+;;; are nested values receivers that have already been reached on
+;;; another walk. We don't want to clobber that result with our null
+;;; initial stack.
(defun stack-analyze (component)
(declare (type component component))
(let* ((2comp (component-info component))
;;; in this component.
(defvar *component-being-compiled*)
+;;; Do-Packed-TNs (TN-Var Component [Result]) Declaration* Form*
+;;;
+;;; Iterate over all packed TNs allocated in Component.
(defmacro do-packed-tns ((tn component &optional result) &body body)
- #!+sb-doc
- "Do-Packed-TNs (TN-Var Component [Result]) Declaration* Form*
- Iterate over all packed TNs allocated in Component."
(let ((n-component (gensym)))
`(let ((,n-component (component-info ,component)))
(do ((,tn (ir2-component-normal-tns ,n-component) (tn-next ,tn)))
,result)
,@body))))
\f
-;;; Remove all TNs with no references from the lists of unpacked TNs. We
-;;; null out the Offset so that nobody will mistake deleted wired TNs for
-;;; properly packed TNs. We mark non-deleted alias TNs so that aliased TNs
-;;; aren't considered to be unreferenced.
+;;; Remove all TNs with no references from the lists of unpacked TNs.
+;;; We null out the Offset so that nobody will mistake deleted wired
+;;; TNs for properly packed TNs. We mark non-deleted alias TNs so that
+;;; aliased TNs aren't considered to be unreferenced.
(defun delete-unreferenced-tns (component)
(let* ((2comp (component-info component))
(aliases (make-array (1+ (ir2-component-global-tn-counter 2comp))
(defun meta-sc-number-or-lose (x)
(the sc-number (sc-number (meta-sc-or-lose x))))
\f
-;;;; side-effect classes
+;;;; side effect classes
(def-boolean-attribute vop
any)
;;;; IR1 annotations used for IR2 conversion
;;; Block-Info
-;;; Holds the IR2-Block structure. If there are overflow blocks,
-;;; then this points to the first IR2-Block. The Block-Info of the
+;;; Holds the IR2-BLOCK structure. If there are overflow blocks,
+;;; then this points to the first IR2-BLOCK. The BLOCK-INFO of the
;;; dummy component head and tail are dummy IR2 blocks that begin
;;; and end the emission order thread.
;;;
;;; Component-Info
-;;; Holds the IR2-Component structure.
+;;; Holds the IR2-COMPONENT structure.
;;;
;;; Continuation-Info
;;; Holds the IR2-Continuation structure. Continuations whose
;; assign all the more args one LTN number, and all the more results
;; another LTN number. We can do this, since more operands are
;; referenced simultaneously as far as conflict analysis is
- ;; concerned. Note that all these :More TNs will be global TNs.
+ ;; concerned. Note that all these :MORE TNs will be global TNs.
(local-tns (make-array local-tn-limit) :type local-tn-vector)
;; Bit-vectors used during lifetime analysis to keep track of
;; references to local TNs. When indexed by the LTN number, the
:type local-tn-bit-vector)
;; This is similar to the above, but is updated by lifetime flow
;; analysis to have a 1 for LTN numbers of TNs live at the end of
- ;; the block. This takes into account all TNs that aren't :Live.
- (live-in (make-array local-tn-limit :element-type 'bit
- :initial-element 0)
+ ;; the block. This takes into account all TNs that aren't :LIVE.
+ (live-in (make-array local-tn-limit :element-type 'bit :initial-element 0)
:type local-tn-bit-vector)
;; a thread running through the global-conflicts structures for this
;; block, sorted by TN number
;; overhead that is eventually stuffed in somehow.
(constants (make-array 10 :fill-pointer 0 :adjustable t) :type vector)
;; some kind of info about the component's run-time representation.
- ;; This is filled in by the VM supplied Select-Component-Format function.
+ ;; This is filled in by the VM supplied SELECT-COMPONENT-FORMAT function.
format
;; a list of the ENTRY-INFO structures describing all of the entries
;; into this component. Filled in by entry analysis.
(entries nil :type list)
- ;; Head of the list of :ALIAS TNs in this component, threaded by TN-NEXT.
+ ;; head of the list of :ALIAS TNs in this component, threaded by TN-NEXT
(alias-tns nil :type (or tn null))
;; SPILLED-VOPS is a hashtable translating from "interesting" VOPs
;; to a list of the TNs spilled at that VOP. This is used when
(def!struct (vop-info
(:include template)
(:make-load-form-fun ignore-it))
- ;; side-effects of this VOP and side-effects that affect the value
+ ;; side effects of this VOP and side effects that affect the value
;; of this VOP
(effects (missing-arg) :type attributes)
(affected (missing-arg) :type attributes)
;; :READ-ONLY
;; The TN is read, but never written. It starts the block live,
;; and is not killed by the block. Lifetime analysis will promote
- ;; :Read-Only TNs to :Live if they are live at the block end.
+ ;; :READ-ONLY TNs to :LIVE if they are live at the block end.
;;
;; :LIVE
;; The TN is not referenced. It is live everywhere in the block.
(kind :read-only :type (member :read :write :read-only :live))
;; a local conflicts vector representing conflicts with TNs live in
- ;; Block. The index for the local TN number of each TN we conflict
- ;; with in this block is 1. To find the full conflict set, the :Live
- ;; TNs for Block must also be included. This slot is not meaningful
- ;; when Kind is :Live.
+ ;; BLOCK. The index for the local TN number of each TN we conflict
+ ;; with in this block is 1. To find the full conflict set, the :LIVE
+ ;; TNs for BLOCK must also be included. This slot is not meaningful
+ ;; when KIND is :LIVE.
(conflicts (make-array local-tn-limit
:element-type 'bit
:initial-element 0)
(tn (missing-arg) :type tn)
;; thread through all the Global-Conflicts for TN
(tn-next nil :type (or global-conflicts null))
- ;; TN's local TN number in Block. :Live TNs don't have local numbers.
+ ;; TN's local TN number in BLOCK. :LIVE TNs don't have local numbers.
(number nil :type (or local-tn-number null)))
(defprinter (global-conflicts)
tn
;;; the last fixed argument. If Variable is false, then the passing
;;; locations are passed as a more arg. Variable is true if there are
;;; a variable number of arguments passed on the stack. Variable
-;;; cannot be specified with :Tail return. TR variable argument call
+;;; cannot be specified with :TAIL return. TR variable argument call
;;; is implemented separately.
;;;
;;; In tail call with fixed arguments, the passing locations are
;;; SET-FUN-NAME-INTERN which takes a list spec for a function
;;; name and turns it into a symbol if need be.
;;;
-;;; When given a funcallable instance, SET-FUN-NAME *must*
-;;; side-effect that FIN to give it the name. When given any other
-;;; kind of function SET-FUN-NAME is allowed to return a new
-;;; function which is "the same" except that it has the name.
+;;; When given a funcallable instance, SET-FUN-NAME *must* side-effect
+;;; that FIN to give it the name. When given any other kind of
+;;; function SET-FUN-NAME is allowed to return a new function which is
+;;; "the same" except that it has the name.
;;;
;;; In all cases, SET-FUN-NAME must return the new (or same)
;;; function. (Unlike other functions to set stuff, it does not return
-;;;; various CHARACTER tests without side-effects
+;;;; various CHARACTER tests without side effects
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
:IOFKTS-LEGACY-791
;; (These aren't really separate bugs, but 804 depends on a
- ;; side-effect of 791, then 812 depends on a side effect of
+ ;; side effect of 791, and then 812 depends on a side effect of
;; 804, so that as long as 791 is suppressed we need to
;; suppress these too.)
:IOFKTS-LEGACY-804
-;;;; miscellaneous compiler tests with side-effects (e.g. DEFUN
+;;;; miscellaneous compiler tests with side effects (e.g. DEFUN
;;;; changing FDEFINITIONs and globaldb stuff)
;;;; This software is part of the SBCL system. See the README file for
-;;;; various compiler tests without side-effects
+;;;; various compiler tests without side effects
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;; This file is for testing debugging functionality, using
-;;;; test machinery which might have side-effects (e.g.
+;;;; test machinery which might have side effects (e.g.
;;;; executing DEFUN).
;;;; This software is part of the SBCL system. See the README file for
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.1.4"
+"0.7.1.13"
projects / sbcl.git / commitdiff