From 82653abf5573c22c691e2243b70647ecdaa6aea8 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Wed, 30 Jan 2002 19:18:27 +0000 Subject: [PATCH] 0.7.1.2: merged APD "compiler inconsistency" patch sbcl-devel 2002-01-30 s/print-tn/print-tn-guts/ FLET should work as well as MACROLET in FIND-OK-TARGET-OFFSET. (The old SBCL code, and maybe the old CMU CL code too, had some horrible efficiency problems with out-of-line structure accessors, but that should be fixed now.) various comment tweaking --- BUGS | 43 ++++++++++++++- src/code/early-type.lisp | 4 +- src/code/float.lisp | 8 +-- src/code/load.lisp | 6 +-- src/code/target-package.lisp | 6 +-- src/code/target-type.lisp | 8 +-- src/code/type-class.lisp | 4 +- src/code/unix.lisp | 5 +- src/cold/shared.lisp | 2 +- src/cold/with-stuff.lisp | 6 +-- src/compiler/alpha/cell.lisp | 4 +- src/compiler/debug.lisp | 56 ++++++++++---------- src/compiler/ir1tran.lisp | 2 +- src/compiler/ir1util.lisp | 4 +- src/compiler/ir2tran.lisp | 6 ++- src/compiler/locall.lisp | 4 +- src/compiler/meta-vmdef.lisp | 11 ++-- src/compiler/pack.lisp | 119 +++++++++++++++++++++++------------------- src/compiler/tn.lisp | 6 +-- src/compiler/vmdef.lisp | 11 ++-- src/compiler/vop.lisp | 35 +++++++------ src/compiler/x86/nlx.lisp | 4 +- src/pcl/defclass.lisp | 1 - version.lisp-expr | 2 +- 24 files changed, 212 insertions(+), 145 deletions(-) diff --git a/BUGS b/BUGS index e70a656..5e2693f 100644 --- a/BUGS +++ b/BUGS @@ -1188,7 +1188,48 @@ WORKAROUND: 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 diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 6dfad22..84e4c1e 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -352,8 +352,8 @@ (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) diff --git a/src/code/float.lisp b/src/code/float.lisp index ee9dacd..5fa7997 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -363,7 +363,7 @@ (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))) @@ -395,7 +395,7 @@ (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)) @@ -527,7 +527,7 @@ 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) @@ -540,7 +540,7 @@ (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)) diff --git a/src/code/load.lisp b/src/code/load.lisp index cea8927..f74a2bc 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -45,8 +45,8 @@ #!-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) @@ -55,7 +55,7 @@ (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)) diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 310b886..a8a8ea7 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -571,9 +571,9 @@ (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)) diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index 0c25448..6bbc5dd 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -135,10 +135,10 @@ (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)) diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index a2d889b..992d3e5 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -100,8 +100,8 @@ ;; 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)) |# diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 3624f60..0978918 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -386,8 +386,9 @@ ;;; 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) diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp index 91fde41..5654245 100644 --- a/src/cold/shared.lisp +++ b/src/cold/shared.lisp @@ -330,7 +330,7 @@ (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 diff --git a/src/cold/with-stuff.lisp b/src/cold/with-stuff.lisp index aff7a7f..47f3086 100644 --- a/src/cold/with-stuff.lisp +++ b/src/cold/with-stuff.lisp @@ -95,9 +95,9 @@ (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* diff --git a/src/compiler/alpha/cell.lisp b/src/compiler/alpha/cell.lisp index 087e4f4..cdee958 100644 --- a/src/compiler/alpha/cell.lisp +++ b/src/compiler/alpha/cell.lisp @@ -63,8 +63,8 @@ (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) diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index d6e226b..9e543c2 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -91,7 +91,7 @@ (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)) @@ -377,7 +377,7 @@ (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)) @@ -393,7 +393,7 @@ (unless fun-deleted (check-node-consistency node)) - + (let ((cont (node-cont node))) (when (not cont) (barf "~S has no CONT." node)) @@ -407,7 +407,7 @@ (unless (eq (continuation-use cont) node) (barf "USE in ~S should be ~S." cont node)) (setq this-cont cont)))) - + (check-block-successors block)) (values)) @@ -557,12 +557,12 @@ ;;;; 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)) @@ -620,8 +620,8 @@ (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) @@ -658,12 +658,12 @@ (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) @@ -722,7 +722,7 @@ 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)) @@ -752,7 +752,7 @@ ((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)) @@ -896,13 +896,13 @@ (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* @@ -1000,9 +1000,9 @@ (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 @@ -1013,8 +1013,8 @@ (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) @@ -1023,15 +1023,15 @@ (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) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 559df42..fd0a643 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -986,7 +986,7 @@ (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) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 987c24a..b437237 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1196,8 +1196,8 @@ (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)) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 2a37493..a6262af 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -81,7 +81,9 @@ (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 "~@" + thing physenv))) ;;; If LEAF already has a constant TN, return that, otherwise make a ;;; TN for it. @@ -696,7 +698,7 @@ (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))) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index ac1f0e0..eb49946 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -697,9 +697,9 @@ (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) diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index e66ea67..9751d99 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -638,6 +638,9 @@ (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 @@ -648,7 +651,9 @@ (+ (* (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) @@ -1755,7 +1760,7 @@ (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))) @@ -1817,7 +1822,7 @@ (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)) diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp index 9830f97..e67f0f9 100644 --- a/src/compiler/pack.lisp +++ b/src/compiler/pack.lisp @@ -337,7 +337,7 @@ (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 @@ -649,10 +649,10 @@ ;;; ;;; 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. @@ -743,10 +743,10 @@ (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) @@ -794,8 +794,8 @@ ;;;; 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*) @@ -805,8 +805,8 @@ (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) @@ -827,8 +827,8 @@ (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. @@ -882,7 +882,7 @@ (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: @@ -964,7 +964,7 @@ (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 @@ -1132,8 +1132,8 @@ (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. @@ -1174,7 +1174,7 @@ (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) @@ -1190,30 +1190,34 @@ (vop-args vop)))))) (values)) -;;;; 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))) @@ -1224,41 +1228,50 @@ 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)))) + ;;;; 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 @@ -1320,7 +1333,7 @@ (if (member (tn-kind tn) '(:save :save-once :specified-save)) (tn-save-tn tn) tn)) - + ;;;; pack interface ;;; Attempt to pack TN in all possible SCs, first in the SC chosen by diff --git a/src/compiler/tn.lisp b/src/compiler/tn.lisp index e0eb8f4..2faa105 100644 --- a/src/compiler/tn.lisp +++ b/src/compiler/tn.lisp @@ -314,7 +314,7 @@ (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)) @@ -326,7 +326,7 @@ (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)) @@ -340,7 +340,7 @@ (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)) diff --git a/src/compiler/vmdef.lisp b/src/compiler/vmdef.lisp index f9882be..fb6c554 100644 --- a/src/compiler/vmdef.lisp +++ b/src/compiler/vmdef.lisp @@ -31,9 +31,9 @@ (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*) @@ -100,6 +100,8 @@ ;; 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)) @@ -152,6 +154,9 @@ (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 diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp index 457616b..455a8b2 100644 --- a/src/compiler/vop.lisp +++ b/src/compiler/vop.lisp @@ -421,7 +421,7 @@ ;;; 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) @@ -430,15 +430,15 @@ ;; 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 @@ -446,7 +446,7 @@ 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))) @@ -465,20 +465,20 @@ (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 @@ -585,10 +585,10 @@ ;; 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 @@ -649,11 +649,12 @@ (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))))) ;;;; SBs and SCs @@ -929,7 +930,7 @@ (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 diff --git a/src/compiler/x86/nlx.lisp b/src/compiler/x86/nlx.lisp index 4d387f3..2550896 100644 --- a/src/compiler/x86/nlx.lisp +++ b/src/compiler/x86/nlx.lisp @@ -88,8 +88,8 @@ (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))) diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 4162031..ba280ee 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -23,7 +23,6 @@ (in-package "SB-PCL") - (defun make-progn (&rest forms) (let ((progn-form nil)) (labels ((collect-forms (forms) diff --git a/version.lisp-expr b/version.lisp-expr index 1ead54c..6a019c5 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.1.1" +"0.7.1.2" -- 1.7.10.4