upgraded to do so. (This doesn't seem to be a high priority
conformance problem, since seems hard to construct useful code
where it matters.)
-
+
+146:
+ Floating point errors are reported poorly. E.g. on x86 OpenBSD
+ with sbcl-0.7.1,
+ * (expt 2.0 12777)
+ debugger invoked on condition of type SB-KERNEL:FLOATING-POINT-EXCEPTION:
+ An arithmetic error SB-KERNEL:FLOATING-POINT-EXCEPTION was signalled.
+ No traps are enabled? How can this be?
+ It should be possible to be much more specific (overflow, division
+ by zero, etc.) and of course the "How can this be?" should be fixable.
+
+147:
+ (reported by Alexey Dejneka sbcl-devel 2002-01-28)
+ Compiling a file containing
+ (deftype digit () '(member #\1))
+ (defun parse-num (string ind)
+ (flet ((digs ()
+ (let (old-index)
+ (if (and (< ind ind)
+ (typep (char string ind) 'digit))
+ nil))))))
+ in sbcl-0.7.1 causes the compiler to fail with
+ internal error, failed AVER: "(= (LENGTH (BLOCK-SUCC CALL-BLOCK)) 1)"
+ This problem seems to have been introduced by the sbcl-0.pre7.* compiler
+ changes, since 0.pre7.73 and 0.6.13 don't suffer from it. A related
+ test case is
+ (defun parse-num (index)
+ (let (num x)
+ (flet ((digs ()
+ (setq num index))
+ (z ()
+ (let ()
+ (setq x nil))))
+ (when (and (digs) (digs)) x))))
+ In sbcl-0.7.1, it failed with the same
+ internal error, failed AVER: "(= (LENGTH (BLOCK-SUCC CALL-BLOCK)) 1)"
+ but after the APD patches in sbcl-0.7.1.2 (new consistency check in
+ TARGET-IF-DESIRABLE, plus a fix in meta-vmdef.lisp to keep the
+ new consistency check from failing routinely) it fails in
+ FIND-IN-PHYSENV instead:
+
+
DEFUNCT CATEGORIES OF BUGS
IR1-#:
These numbers were used for bugs related to the old IR1
(error "bad thing to be a type specifier: ~S"
spec))))))))))
-;;; Like VALUES-SPECIFIER-TYPE, except that we guarantee to never
-;;; return a VALUES type.
+;;; This is like VALUES-SPECIFIER-TYPE, except that we guarantee to
+;;; never return a VALUES type.
(defun specifier-type (x)
(let ((res (values-specifier-type x)))
(when (values-type-p res)
(t
(values (logior sig sb!vm:single-float-hidden-bit) biased sign)))))
-;;; Like INTEGER-DECODE-SINGLE-DENORM, only doubly so.
+;;; like INTEGER-DECODE-SINGLE-DENORM, only doubly so
(defun integer-decode-double-denorm (x)
(declare (type double-float x))
(let* ((high-bits (double-float-high-bits (abs x)))
(truly-the fixnum (- biased extra-bias))
sign)))))
-;;; Like INTEGER-DECODE-SINGLE-FLOAT, only doubly so.
+;;; like INTEGER-DECODE-SINGLE-FLOAT, only doubly so
(defun integer-decode-double-float (x)
(declare (double-float x))
(let* ((abs (abs x))
bits))
biased sign)))))
-;;; Like DECODE-SINGLE-DENORM, only doubly so.
+;;; like DECODE-SINGLE-DENORM, only doubly so
(defun decode-double-denorm (x)
(declare (double-float x))
(multiple-value-bind (sig exp sign) (integer-decode-double-denorm x)
(truly-the fixnum (+ exp sb!vm:double-float-digits))
(float sign x))))
-;;; Like DECODE-SINGLE-FLOAT, only doubly so.
+;;; like DECODE-SINGLE-FLOAT, only doubly so
(defun decode-double-float (x)
(declare (double-float x))
(let* ((abs (abs x))
#!-sb-fluid (declaim (inline read-byte))
-;;; Expands into code to read an N-byte unsigned integer using
-;;; fast-read-byte.
+;;; This expands into code to read an N-byte unsigned integer using
+;;; FAST-READ-BYTE.
(defmacro fast-read-u-integer (n)
(declare (optimize (speed 0)))
(do ((res '(fast-read-byte)
(cnt 1 (1+ cnt)))
((>= cnt n) res)))
-;;; Like Fast-Read-U-Integer, but the size may be determined at run time.
+;;; like FAST-READ-U-INTEGER, but the size may be determined at run time
(defmacro fast-read-var-u-integer (n)
(let ((n-pos (gensym))
(n-res (gensym))
(t
(error "~S is neither a symbol nor a list of symbols." thing))))
-;;; Like UNINTERN, but if symbol is inherited chases down the package
-;;; it is inherited from and uninterns it there. Used for
-;;; name-conflict resolution. Shadowing symbols are not uninterned
+;;; This is like UNINTERN, except if SYMBOL is inherited, it chases
+;;; down the package it is inherited from and uninterns it there. Used
+;;; for name-conflict resolution. Shadowing symbols are not uninterned
;;; since they do not cause conflicts.
(defun moby-unintern (symbol package)
(unless (member symbol (package-%shadowing-symbols package))
(funcall (symbol-function sym))))
(values))
-;;; Like TYPE-OF, only we return a CTYPE structure instead of a type
-;;; specifier, and we try to return the type most useful for type
-;;; checking, rather than trying to come up with the one that the user
-;;; might find most informative.
+;;; This is like TYPE-OF, only we return a CTYPE structure instead of
+;;; a type specifier, and we try to return the type most useful for
+;;; type checking, rather than trying to come up with the one that the
+;;; user might find most informative.
(declaim (ftype (function (t) ctype) ctype-of))
(defun-cached (ctype-of
:hash-function (lambda (x) (logand (sxhash x) #x1FF))
;; supplying both.
(unary-typep nil :type (or symbol null))
(typep nil :type (or symbol null))
- ;; Like TYPEP, UNARY-TYPEP except these functions coerce objects to this
- ;; type.
+ ;; These are like TYPEP and UNARY-TYPEP except they coerce objects to
+ ;; the type.
(unary-coerce nil :type (or symbol null))
(coerce :type (or symbol null))
|#
;;; FIXME: All we seem to need is the RUSAGE_SELF version of this.
;;;
-;;; Like getrusage(2), but return only the system and user time,
-;;; and return the seconds and microseconds as separate values.
+;;; This is like getrusage(2), except it returns only the system and
+;;; user time, and returns the seconds and microseconds as separate
+;;; values.
#!-sb-fluid (declaim (inline unix-fast-getrusage))
(defun unix-fast-getrusage (who)
(declare (values (member t)
(load compiled-filename)))
(compile 'host-cload-stem)
-;;; Like HOST-CLOAD-STEM, except that we don't bother to compile.
+;;; like HOST-CLOAD-STEM, except that we don't bother to compile
(defun host-load-stem (stem &key ignore-failure-p)
(declare (ignore ignore-failure-p)) ; (It's only relevant when
;; compiling.) KLUDGE: It's untidy to have the knowledge of how to
(compile '%without-given-nickname)
(compile '%multi-nickname-magic)
-;;; Like WITH-ADDITIONAL-NICKNAME and WITHOUT-GIVEN-NICKNAMES, except
-;;; working on arbitrary lists of nickname descriptors instead of
-;;; single nickname/package pairs.
+;;; This is like WITH-ADDITIONAL-NICKNAME and WITHOUT-GIVEN-NICKNAMES,
+;;; except working on arbitrary lists of nickname descriptors instead
+;;; of single nickname/package pairs.
;;;
;;; A nickname descriptor is a list of the form
;;; PACKAGE-DESIGNATOR NICKNAME*
(inst xor value unbound-marker-widetag temp)
(inst beq temp err-lab))))
-;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell
-;;; is bound.
+;;; like CHECKED-CELL-REF, only we are a predicate to see if the cell
+;;; is bound
(define-vop (boundp-frob)
(:args (object :scs (descriptor-reg)))
(:conditional)
(block head (block-next block)))
((null block)
(unless (eq prev tail)
- (barf "wrong Tail for DFO, ~S in ~S" prev c)))
+ (barf "wrong TAIL for DFO, ~S in ~S" prev c)))
(setf (gethash block *seen-blocks*) t)
(unless (eq (block-prev block) prev)
(barf "bad PREV for ~S, should be ~S" block prev))
(when dest
(check-node-reached dest)))
- (loop
+ (loop
(unless (eq (continuation-block this-cont) block)
(barf "BLOCK in ~S should be ~S." this-cont block))
(unless fun-deleted
(check-node-consistency node))
-
+
(let ((cont (node-cont node)))
(when (not cont)
(barf "~S has no CONT." node))
(unless (eq (continuation-use cont) node)
(barf "USE in ~S should be ~S." cont node))
(setq this-cont cont))))
-
+
(check-block-successors block))
(values))
\f
;;;; IR2 consistency checking
-;;; Check for some kind of consistency in some Refs linked together by
-;;; TN-Ref-Across. VOP is the VOP that the references are in. Write-P is the
-;;; value of Write-P that should be present. Count is the minimum number of
-;;; operands expected. If More-P is true, then any larger number will also be
-;;; accepted. What is a string describing the kind of operand in error
-;;; messages.
+;;; Check for some kind of consistency in some REFs linked together by
+;;; TN-REF-ACROSS. VOP is the VOP that the references are in. WRITE-P
+;;; is the value of WRITE-P that should be present. COUNT is the
+;;; minimum number of operands expected. If MORE-P is true, then any
+;;; larger number will also be accepted. WHAT is a string describing
+;;; the kind of operand in error messages.
(defun check-tn-refs (refs vop write-p count more-p what)
(let ((vop-refs (vop-refs vop)))
(do ((ref refs (tn-ref-across ref))
(values))
;;; Check the basic sanity of the VOP linkage, then call some other
-;;; functions to check on the TN-Refs. We grab some info out of the VOP-Info
-;;; to tell us what to expect.
+;;; functions to check on the TN-REFS. We grab some info out of the
+;;; VOP-INFO to tell us what to expect.
;;;
;;; [### Check that operand type restrictions are met?]
(defun check-ir2-block-consistency (2block)
(barf "wrong number of codegen info args in ~S" vop))))
(values))
-;;; Check stuff about the IR2 representation of Component. This assumes the
+;;; Check stuff about the IR2 representation of COMPONENT. This assumes the
;;; sanity of the basic flow graph.
;;;
;;; [### Also grovel global TN data structures? Assume pack not
-;;; done yet? Have separate check-tn-consistency for pre-pack and
-;;; check-pack-consistency for post-pack?]
+;;; done yet? Have separate CHECK-TN-CONSISTENCY for pre-pack and
+;;; CHECK-PACK-CONSISTENCY for post-pack?]
(defun check-ir2-consistency (component)
(declare (type component component))
(do-ir2-blocks (block component)
confs))
(values))
-;;; If the entry in Local-TNs for TN in Block is :More, then do some checks
+;;; If the entry in Local-TNs for TN in BLOCK is :MORE, then do some checks
;;; for the validity of the usage.
(defun check-more-tn-entry (tn block)
(let* ((vop (ir2-block-start-vop block))
((eq kind :component)
(unless (member tn (ir2-component-component-tns
(component-info component)))
- (barf "~S not in Component-TNs for ~S" tn component)))
+ (barf "~S not in COMPONENT-TNs for ~S" tn component)))
(conf
(do ((conf conf (global-conflicts-tn-next conf))
(prev nil conf))
(proclaim '(hash-table ,vto ,vfrom))
(defvar ,counter 0)
(proclaim '(fixnum ,counter))
-
+
(defun ,fto (x)
(or (gethash x ,vto)
(let ((num (incf ,counter)))
(setf (gethash num ,vfrom) x)
(setf (gethash x ,vto) num))))
-
+
(defun ,ffrom (num)
(values (gethash num ,vfrom))))))
(def *continuation-number* *continuation-numbers* *number-continuations*
(mapcar (lambda (x) (cont-num (block-start x))) succ)))
(values))
-;;; Print a useful representation of a TN. If the TN has a leaf, then do a
-;;; Print-Leaf on that, otherwise print a generated ID.
-(defun print-tn (tn &optional (stream *standard-output*))
+;;; Print the guts of a TN. (logic shared between PRINT-OBJECT (TN T)
+;;; and printers for compound objects which contain TNs)
+(defun print-tn-guts (tn &optional (stream *standard-output*))
(declare (type tn tn))
(let ((leaf (tn-leaf tn)))
(cond (leaf
(when (and (tn-sc tn) (tn-offset tn))
(format stream "[~A]" (location-print-name tn)))))
-;;; Print the TN-Refs representing some operands to a VOP, linked by
-;;; TN-Ref-Across.
+;;; Print the TN-REFs representing some operands to a VOP, linked by
+;;; TN-REF-ACROSS.
(defun print-operands (refs)
(declare (type (or tn-ref null) refs))
(pprint-logical-block (*standard-output* nil)
(let ((tn (tn-ref-tn ref))
(ltn (tn-ref-load-tn ref)))
(cond ((not ltn)
- (print-tn tn))
+ (print-tn-guts tn))
(t
- (print-tn tn)
+ (print-tn-guts tn)
(princ (if (tn-ref-write-p ref) #\< #\>))
- (print-tn ltn)))
+ (print-tn-guts ltn)))
(princ #\space)
(pprint-newline :fill)))))
-;;; Print the vop, putting args, info and results on separate lines, if
+;;; Print the VOP, putting args, info and results on separate lines, if
;;; necessary.
(defun print-vop (vop)
(pprint-logical-block (*standard-output* nil)
(make-lexenv :default res :funs new-fenv)
res)))
-;;; Like FIND-IN-BINDINGS, but looks for #'foo in the fvars.
+;;; like FIND-IN-BINDINGS, but looks for #'FOO in the FVARS
(defun find-in-bindings-or-fbindings (name vars fvars)
(declare (list vars fvars))
(if (consp name)
(change-ref-leaf ref new-leaf))
(values))
-;;; Like SUBSITUTE-LEAF, only there is a predicate on the REF to tell
-;;; whether to substitute.
+;;; like SUBSITUTE-LEAF, only there is a predicate on the REF to tell
+;;; whether to substitute
(defun substitute-leaf-if (test new-leaf old-leaf)
(declare (type leaf new-leaf old-leaf) (type function test))
(dolist (ref (leaf-refs old-leaf))
(leaf-info thing))
(nlx-info
(aver (eq physenv (block-physenv (nlx-info-target thing))))
- (ir2-nlx-info-home (nlx-info-info thing))))))
+ (ir2-nlx-info-home (nlx-info-info thing))))
+ (error "~@<internal error: ~2I~_~S ~_not found in ~_~S~:>"
+ thing physenv)))
;;; If LEAF already has a constant TN, return that, otherwise make a
;;; TN for it.
(dolist (thing (ir2-physenv-closure called-env))
(temps (find-in-physenv (car thing) this-1env))
(locs (cdr thing)))
-
+
(temps old-fp)
(locs (ir2-physenv-old-fp called-env)))
(join-components component clambda-component)))
(let ((*current-component* component))
(node-ends-block call))
- ;; FIXME: Use PROPER-LIST-OF-LENGTH-P here, and look for other
+ ;; FIXME: Use DESTRUCTURING-BIND here, and grep for other
;; uses of '=.*length' which could also be converted to use
- ;; PROPER-LIST-OF-LENGTH-P.
+ ;; DESTRUCTURING-BIND or PROPER-LIST-OF-LENGTH-P.
(aver (= (length (block-succ call-block)) 1))
(let ((next-block (first (block-succ call-block))))
(unlink-blocks call-block next-block)
(operand-parse-name op)))
(let ((target (find-operand (operand-parse-target op) parse
'(:temporary :result))))
+ ;; KLUDGE: These formulas must be consistent with those in
+ ;; %EMIT-GENERIC-VOP, and this is currently maintained by
+ ;; hand. -- WHN 2002-01-30, paraphrasing APD
(targets (+ (* index max-vop-tn-refs)
(ecase (operand-parse-kind target)
(:result
(+ (* (position-or-lose target
(vop-parse-temps parse))
2)
- num-args num-results)))))))
+ 1
+ num-args
+ num-results)))))))
(let ((born (operand-parse-born op))
(dies (operand-parse-dies op)))
(ecase (operand-parse-kind op)
(make-operand-list (subseq operands 0 arg-count) nil nil)
(multiple-value-bind (rcode rbinds n-results)
(make-operand-list (subseq operands (+ arg-count info-count)) nil t)
-
+
(collect ((ibinds)
(ivars))
(dolist (info (subseq operands arg-count (+ arg-count info-count)))
(make-operand-list fixed-args (car (last args)) nil)
(multiple-value-bind (rcode rbinds n-results)
(make-operand-list fixed-results (car (last results)) t)
-
+
`(let* ((,n-node ,node)
(,n-block ,block)
(,n-template (template-or-lose ',name))
(args (vop-args vop))
(results (vop-results vop))
(name (with-output-to-string (stream)
- (print-tn tn stream)))
+ (print-tn-guts tn stream)))
(2comp (component-info *component-being-compiled*))
temp)
(cond
;;;
;;; SAVES and RESTORES are represented using both a list and a
;;; bit-vector so that we can quickly iterate and test for membership.
-;;; The incoming Saves and Restores args are used for computing these
+;;; The incoming SAVES and RESTORES args are used for computing these
;;; sets (the initial contents are ignored.)
;;;
-;;; When we hit a VOP with :COMPUTE-ONLY Save-P (an internal error
+;;; When we hit a VOP with :COMPUTE-ONLY SAVE-P (an internal error
;;; location), we pretend that all live TNs were read, unless (= speed
;;; 3), in which case we mark all the TNs that are live but not
;;; restored as spilled.
(do ((read (vop-args vop) (tn-ref-across read)))
((null read))
(save-note-read (tn-ref-tn read))))))))))
-
-;;; Like EMIT-SAVES, only different. We avoid redundant saving within
-;;; the block, and don't restore values that aren't used before the
-;;; next call. This function is just the top level loop over the
+
+;;; This is like EMIT-SAVES, only different. We avoid redundant saving
+;;; within the block, and don't restore values that aren't used before
+;;; the next call. This function is just the top level loop over the
;;; blocks in the component, which locates blocks that need saving
;;; done.
(defun optimized-emit-saves (component)
;;;; load TN packing
;;; These variables indicate the last location at which we computed
-;;; the Live-TNs. They hold the Block and VOP values that were passed
-;;; to Compute-Live-TNs.
+;;; the Live-TNs. They hold the BLOCK and VOP values that were passed
+;;; to COMPUTE-LIVE-TNS.
(defvar *live-block*)
(defvar *live-vop*)
(defvar *repack-blocks*)
(declaim (type (or hash-table null) *repack-blocks*))
-;;; Set the Live-TNs vectors in all :Finite SBs to represent the TNs
-;;; live at the end of Block.
+;;; Set the Live-TNs vectors in all :FINITE SBs to represent the TNs
+;;; live at the end of BLOCK.
(defun init-live-tns (block)
(dolist (sb *backend-sb-list*)
(when (eq (sb-kind sb) :finite)
(values))
-;;; Set the Live-TNs in :Finite SBs to represent the TNs live
-;;; immediately after the evaluation of VOP in Block, excluding
+;;; Set the LIVE-TNs in :FINITE SBs to represent the TNs live
+;;; immediately after the evaluation of VOP in BLOCK, excluding
;;; results of the VOP. If VOP is null, then compute the live TNs at
;;; the beginning of the block. Sequential calls on the same block
;;; must be in reverse VOP order.
(setq *live-vop* vop)
(values))
-;;; This is kind of like Offset-Conflicts-In-SB, except that it uses
+;;; This is kind of like OFFSET-CONFLICTS-IN-SB, except that it uses
;;; the VOP refs to determine whether a Load-TN for OP could be packed
;;; in the specified location, disregarding conflicts with TNs not
;;; referenced by this VOP. There is a conflict if either:
(load-tn-offset-conflicts-in-sb op sb i))))
(when res (return res))))))
-;;; If a load-TN for Op is targeted to a legal location in SC, then
+;;; If a load-TN for OP is targeted to a legal location in SC, then
;;; return the offset, otherwise return NIL. We see whether the target
;;; of the operand is packed, and try that location. There isn't any
;;; need to chain down the target path, since everything is packed
(return res))))
(push sc allowed)))))))))
-;;; Scan a list of load-SCs vectors and a list of TN-Refs threaded by
-;;; TN-Ref-Across. When we find a reference whose TN doesn't satisfy
+;;; Scan a list of load-SCs vectors and a list of TN-REFS threaded by
+;;; TN-REF-ACROSS. When we find a reference whose TN doesn't satisfy
;;; the restriction, we pack a Load-TN and load the operand into it.
;;; If a load-tn has already been allocated, we can assume that the
;;; restriction is satisfied.
(values))
-;;; Scan the VOPs in Block, looking for operands whose SC restrictions
+;;; Scan the VOPs in BLOCK, looking for operands whose SC restrictions
;;; aren't satisfied. We do the results first, since they are
;;; evaluated later, and our conflict analysis is a backward scan.
(defun pack-load-tns (block)
(vop-args vop))))))
(values))
\f
-;;;; location-selection, targeting & pack interface
-
;;;; targeting
-;;; Link the TN-Refs Read and Write together using the TN-Ref-Target when
-;;; this seems like a good idea. Currently we always do, as this increases the
-;;; success of load-TN targeting.
+;;; Link the TN-REFS READ and WRITE together using the TN-REF-TARGET
+;;; when this seems like a good idea. Currently we always do, as this
+;;; increases the success of load-TN targeting.
(defun target-if-desirable (read write)
(declare (type tn-ref read write))
+ ;; As per the comments at the definition of TN-REF-TARGET, read and
+ ;; write refs are always paired, with TARGET in the read pointing to
+ ;; the write and vice versa.
+ (aver (eq (tn-ref-write-p read)
+ (not (tn-ref-write-p write))))
(setf (tn-ref-target read) write)
(setf (tn-ref-target write) read))
;;; If TN can be packed into SC so as to honor a preference to TARGET,
;;; then return the offset to pack at, otherwise return NIL. TARGET
-;;; must be already packed. We can honor a preference if:
-;;; -- TARGET's location is in SC's locations.
-;;; -- The element sizes of the two SCs are the same.
-;;; -- TN doesn't conflict with target's location.
+;;; must be already packed.
(defun check-ok-target (target tn sc)
(declare (type tn target tn) (type sc sc) (inline member))
(let* ((loc (tn-offset target))
(target-sc (tn-sc target))
(target-sb (sc-sb target-sc)))
(declare (type index loc))
+ ;; We can honor a preference if:
+ ;; -- TARGET's location is in SC's locations.
+ ;; -- The element sizes of the two SCs are the same.
+ ;; -- TN doesn't conflict with target's location.
(if (and (eq target-sb (sc-sb sc))
(or (eq (sb-kind target-sb) :unbounded)
(member loc (sc-locations sc)))
nil)))
;;; Scan along the target path from TN, looking at readers or writers.
-;;; When we find a packed TN, return Check-OK-Target of that TN. If
+;;; When we find a packed TN, return CHECK-OK-TARGET of that TN. If
;;; there is no target, or if the TN has multiple readers (writers),
;;; then we return NIL. We also always return NIL after 10 iterations
;;; to get around potential circularity problems.
-(macrolet ((frob (slot)
- `(let ((count 10)
- (current tn))
- (declare (type index count))
- (loop
- (let ((refs (,slot current)))
- (unless (and (plusp count) refs (not (tn-ref-next refs)))
- (return nil))
- (let ((target (tn-ref-target refs)))
- (unless target (return nil))
- (setq current (tn-ref-tn target))
- (when (tn-offset current)
- (return (check-ok-target current tn sc)))
- (decf count)))))))
- (defun find-ok-target-offset (tn sc)
- (declare (type tn tn) (type sc sc))
- (or (frob tn-reads)
- (frob tn-writes))))
-
+;;;
+;;; FIXME: (30 minutes of reverse engineering?) It'd be nice to
+;;; rewrite the header comment here to explain the interface and its
+;;; motivation, and move remarks about implementation details (like
+;;; 10!) inside.
+(defun find-ok-target-offset (tn sc)
+ (declare (type tn tn) (type sc sc))
+ (flet ((frob-slot (slot-fun)
+ (declare (type function slot-fun))
+ (let ((count 10)
+ (current tn))
+ (declare (type index count))
+ (loop
+ (let ((refs (funcall slot-fun current)))
+ (unless (and (plusp count)
+ refs
+ (not (tn-ref-next refs)))
+ (return nil))
+ (let ((target (tn-ref-target refs)))
+ (unless target (return nil))
+ (setq current (tn-ref-tn target))
+ (when (tn-offset current)
+ (return (check-ok-target current tn sc)))
+ (decf count)))))))
+ (declare (inline frob-slot)) ; until DYNAMIC-EXTENT works
+ (or (frob-slot #'tn-reads)
+ (frob-slot #'tn-writes))))
+\f
;;;; location selection
;;; Select some location for TN in SC, returning the offset if we
;;; succeed, and NIL if we fail. We start scanning at the Last-Offset
;;; in an attempt to distribute the TNs across all storage.
;;;
-;;; We call Offset-Conflicts-In-SB directly, rather than using
-;;; Conflicts-In-SC. This allows us to more efficient in packing
+;;; We call OFFSET-CONFLICTS-IN-SB directly, rather than using
+;;; CONFLICTS-IN-SC. This allows us to more efficient in packing
;;; multi-location TNs: we don't have to multiply the number of tests
-;;; by the TN size. This falls out natually, since we have to be aware
-;;; of TN size anyway so that we don't call Conflicts-In-SC on a bogus
-;;; offset.
+;;; by the TN size. This falls out naturally, since we have to be
+;;; aware of TN size anyway so that we don't call CONFLICTS-IN-SC on a
+;;; bogus offset.
;;;
;;; We give up on finding a location after our current pointer has
;;; wrapped twice. This will result in testing some locations twice in
(if (member (tn-kind tn) '(:save :save-once :specified-save))
(tn-save-tn tn)
tn))
-
+\f
;;;; pack interface
;;; Attempt to pack TN in all possible SCs, first in the SC chosen by
(insert-vop-sequence first last block before)
last)))
-;;; Like EMIT-MOVE-TEMPLATE, except that we pass in Info args too.
+;;; like EMIT-MOVE-TEMPLATE, except that we pass in INFO args too
(defun emit-load-template (node block template x y info &optional before)
(declare (type node node) (type ir2-block block)
(type template template) (type tn x y))
(insert-vop-sequence first last block before)
last)))
-;;; Like EMIT-MOVE-TEMPLATE, except that the VOP takes two args.
+;;; like EMIT-MOVE-TEMPLATE, except that the VOP takes two args
(defun emit-move-arg-template (node block template x f y &optional before)
(declare (type node node) (type ir2-block block)
(type template template) (type tn x f y))
(insert-vop-sequence first last block before)
last)))
-;;; Like EMIT-MOVE-TEMPLATE, except that the VOP takes no args.
+;;; like EMIT-MOVE-TEMPLATE, except that the VOP takes no args
(defun emit-context-template (node block template y &optional before)
(declare (type node node) (type ir2-block block)
(type template template) (type tn y))
(defun sc-number-or-lose (x)
(the sc-number (sc-number (sc-or-lose x))))
-;;; Like the non-meta versions, but go for the meta-compile-time info.
-;;; These should not be used after load time, since compiling the compiler
-;;; changes the definitions.
+;;; This is like the non-meta versions, except we go for the
+;;; meta-compile-time info. These should not be used after load time,
+;;; since compiling the compiler changes the definitions.
(defun meta-sc-or-lose (x)
(the sc
(or (gethash x *backend-meta-sc-names*)
;; We need the EVAL-WHEN because %EMIT-GENERIC-VOP (below)
;; uses #.MAX-VOP-TN-REFS, not just MAX-VOP-TN-REFS.
;; -- AL 20010218
+ ;;
+ ;; See also the description of VOP-INFO-TARGETS. -- APD, 2002-01-30
(defconstant max-vop-tn-refs 256))
(defvar *vop-tn-refs* (make-array max-vop-tn-refs :initial-element nil))
(ash temp (- (1+ sc-bits))))
(make-restricted-tn nil (ash temp -1))))
(write-ref (reference-tn tn t)))
+ ;; KLUDGE: These formulas must be consistent with those in
+ ;; COMPUTE-REF-ORDERING, and this is currently
+ ;; maintained by hand. -- WHN 2002-01-30, paraphrasing APD
(setf (aref refs index) (reference-tn tn nil))
(setf (aref refs (1+ index)) write-ref)
(if prev
;;; operands to the operation.
(defstruct (vop (:constructor make-vop (block node info args results))
(:copier nil))
- ;; VOP-Info structure containing static info about the operation
+ ;; VOP-INFO structure containing static info about the operation
(info nil :type (or vop-info null))
;; the IR2-Block this VOP is in
(block (missing-arg) :type ir2-block)
;; translation.
(next nil :type (or vop null))
(prev nil :type (or vop null))
- ;; heads of the TN-Ref lists for operand TNs, linked using the
- ;; Across slot
+ ;; heads of the TN-REF lists for operand TNs, linked using the
+ ;; ACROSS slot
(args nil :type (or tn-ref null))
(results nil :type (or tn-ref null))
;; head of the list of write refs for each explicitly allocated
- ;; temporary, linked together using the Across slot
+ ;; temporary, linked together using the ACROSS slot
(temps nil :type (or tn-ref null))
- ;; head of the list of all TN-refs for references in this VOP,
- ;; linked by the Next-Ref slot. There will be one entry for each
+ ;; head of the list of all TN-REFs for references in this VOP,
+ ;; linked by the NEXT-REF slot. There will be one entry for each
;; operand and two (a read and a write) for each temporary.
(refs nil :type (or tn-ref null))
;; stuff that is passed uninterpreted from IR2 conversion to
codegen-info
;; the node that generated this VOP, for keeping track of debug info
(node nil :type (or node null))
- ;; Local-TN bit vector representing the set of TNs live after args
+ ;; LOCAL-TN-BIT-VECTOR representing the set of TNs live after args
;; are read and before results are written. This is only filled in
;; when VOP-INFO-SAVE-P is non-null.
(save-set nil :type (or local-tn-bit-vector null)))
(tn (missing-arg) :type tn)
;; Is this is a write reference? (as opposed to a read reference)
(write-p nil :type boolean)
- ;; the link for a list running through all TN-Refs for this TN of
+ ;; the link for a list running through all TN-REFs for this TN of
;; the same kind (read or write)
(next nil :type (or tn-ref null))
;; the VOP where the reference happens, or NIL temporarily
(vop nil :type (or vop null))
- ;; the link for a list of all TN-Refs in VOP, in reverse order of
+ ;; the link for a list of all TN-REFs in VOP, in reverse order of
;; reference
(next-ref nil :type (or tn-ref null))
- ;; the link for a list of the TN-Refs in VOP of the same kind
+ ;; the link for a list of the TN-REFs in VOP of the same kind
;; (argument, result, temp)
(across nil :type (or tn-ref null))
- ;; If true, this is a TN-Ref also in VOP whose TN we would like
+ ;; If true, this is a TN-REF also in VOP whose TN we would like
;; packed in the same location as our TN. Read and write refs are
- ;; always paired: Target in the read points to the write, and
+ ;; always paired: TARGET in the read points to the write, and
;; vice-versa.
(target nil :type (or null tn-ref))
;; the load TN allocated for this operand, if any
;; save-sc will be saved in a TN in the save SC before the VOP
;; and restored after the VOP. This is used by call VOPs. A bit
;; vector representing the live TNs is stored in the VOP-SAVE-SET.
- ;; -- If :Force-To-Stack, all such TNs will made into :Environment TNs
+ ;; -- If :FORCE-TO-STACK, all such TNs will made into :ENVIRONMENT TNs
;; and forced to be allocated in SCs without any save-sc. This is
;; used by NLX entry vops.
- ;; -- If :Compute-Only, just compute the save set, don't do any saving.
+ ;; -- If :COMPUTE-ONLY, just compute the save set, don't do any saving.
;; This is used to get the live variables for debug info.
(save-p nil :type (member t nil :force-to-stack :compute-only))
;; info for automatic emission of move-arg VOPs by representation
(temps nil :type (or null (specializable-vector (unsigned-byte 16))))
;; the order all the refs for this vop should be put in. Each
;; operand is assigned a number in the following ordering: args,
- ;; more-args, results, more-results, temps This vector represents
+ ;; more-args, results, more-results, temps. This vector represents
;; the order the operands should be put into in the next-ref link.
(ref-ordering nil :type (or null (specializable-vector (unsigned-byte 8))))
;; a vector of the various targets that should be done. Each element
- ;; encodes the source ref (shifted 8) and the dest ref index.
+ ;; encodes the source ref (shifted 8, it is also encoded in
+ ;; MAX-VOP-TN-REFS) and the dest ref index.
(targets nil :type (or null (specializable-vector (unsigned-byte 16)))))
\f
;;;; SBs and SCs
(print-unreadable-object (tn stream :type t)
;; KLUDGE: The distinction between PRINT-TN and PRINT-OBJECT on TN is
;; not very mnemonic. -- WHN 20000124
- (print-tn tn stream)))
+ (print-tn-guts tn stream)))
;;; The GLOBAL-CONFLICTS structure represents the conflicts for global
;;; TNs. Each global TN has a list of these structures, one for each
(storew (make-fixup nil :code-object entry-label)
block catch-block-entry-pc-slot)))
-;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
-;;; link the block into the Current-Catch list.
+;;; like MAKE-UNWIND-BLOCK, except that we also store in the specified
+;;; tag, and link the block into the CURRENT-CATCH list
(define-vop (make-catch-block)
(:args (tn)
(tag :scs (descriptor-reg) :to (:result 1)))
(in-package "SB-PCL")
\f
-
(defun make-progn (&rest forms)
(let ((progn-form nil))
(labels ((collect-forms (forms)
;;; 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.1"
+"0.7.1.2"
projects / sbcl.git / commitdiff