From: William Harold Newman Date: Wed, 22 Aug 2001 12:52:02 +0000 (+0000) Subject: 0.pre7.14.flaky4.7: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=95f5ac2fa70b3f14d052e20f4250166f219dcc39;p=sbcl.git 0.pre7.14.flaky4.7: rewrote UNIX-FAST-SELECT as an inline function (and resurrected all the old argument DECLAREs) fixed weirdness in DISASSEMBLE.. ..Why does it use a different output format for (DISASSEMBLE (SB-DEBUG:ARG 0)) from the debugger prompt (where it properly inserts a space between bytecode and translation) and display of the same function with (DISASSEMBLE (SB-XC:MACRO-FUNCTION 'SB!EXT:WITH-ALIEN)) from the main command prompt? I think it's weirdness with "~12T" in DISASSEM-BYTE-SAP. Try changing to " ~14T" instead. ..Why does it stop output from disassembly of byte-compiled WITH-ALIEN at byte 83, when that looks like a completely unnatural stopping point? It seems to be that *PRINT-LINES* is rebound to a small value, and then the outer PPRINT-LOGICAL-BLOCK (used to prepend #\; to each line of output) tests the current dynamical value and bails out. So make PRETTY-STREAM grab the *PRINT-LINES* value at ctor time and use that, rather than the dynamic value, when deciding whether to truncate output bumped fasl file version number since PRETTY-STREAM layout changed --- diff --git a/NEWS b/NEWS index 8d0c889..7882996 100644 --- a/NEWS +++ b/NEWS @@ -837,9 +837,21 @@ changes in sbcl-0.7.0 relative to sbcl-0.6.13: ?? IR1-3a. It's also done by much newer code, so there might be some new bugs, but hopefully if so they'll be less fundamental and more fixable. +* PPRINT-LOGICAL-BLOCK now copies the *PRINT-LINES* value on entry + and uses that copy, rather than the current dynamic value, when + it's trying to decide whether to truncate output . Thus e.g. + (let ((*print-lines* 50)) + (pprint-logical-block (stream nil) + (dotimes (i 10) + (let ((*print-lines* 8)) + (print (aref possiblybigthings i) stream))))) + should truncate the logical block only at 50 lines, instead of + often truncating it at 8 lines. ?? lots of tidying up internally: renaming things so that names are more systematic and consistent, converting C macros to inline functions, systematizing indentation +* The fasl file version number changed again, for any number of + good reasons. planned incompatible changes in 0.7.x: * The debugger prompt sequence now goes "5]", "5[2]", "5[3]", etc. diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index ad3a303..ea6149b 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -670,7 +670,7 @@ ;;;; frames -;;; This is used in FIND-ESCAPE-FRAME and with the bogus components +;;; This is used in FIND-ESCAPED-FRAME and with the bogus components ;;; and LRAs used for :function-end breakpoints. When a components ;;; debug-info slot is :bogus-lra, then the real-lra-slot contains the ;;; real component to continue executing, as opposed to the bogus diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index 8b2af91..1afac33 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -38,7 +38,7 @@ ;;; This value should be incremented when the system changes in such ;;; a way that it will no longer work reliably with old fasl files. -(defconstant +fasl-file-version+ 15) +(defconstant +fasl-file-version+ 16) ;;; 2 = sbcl-0.6.4 uses COMPILE-OR-LOAD-DEFGENERIC. ;;; 3 = sbcl-0.6.6 uses private symbol, not :EMPTY, for empty HASH-TABLE slot. ;;; 4 = sbcl-0.6.7 uses HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET @@ -65,6 +65,7 @@ ;;; 13 = sbcl-0.6.12.28 removed some elements from *STATIC-SYMBOLS* ;;; 14 = sbcl-0.6.12.29 removed more elements from *STATIC-SYMBOLS* ;;; 15 = sbcl-0.6.12.33 changed the layout of STREAM +;;; 16 = sbcl-0.pre7.15 changed the layout of PRETTY-STREAM ;;; the conventional file extension for fasl files on this ;;; architecture, e.g. "x86f" diff --git a/src/code/extensions.lisp b/src/code/extensions.lisp index 6d25386..3ae801f 100644 --- a/src/code/extensions.lisp +++ b/src/code/extensions.lisp @@ -874,12 +874,3 @@ (if (typep possibly-logical-pathname 'logical-pathname) (translate-logical-pathname possibly-logical-pathname) possibly-logical-pathname)) - -#| -;;; REMOVEME when done testing byte cross-compiler -(defun byte-compiled-foo (x y) - (declare (optimize (speed 0) (debug 1))) - (if x - x - (cons y y))) -|# diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index ec285d7..4778e9f 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -56,9 +56,20 @@ ;; zero, but if we end up with a very long line with no breaks in it we ;; might have to output part of it. Then this will no longer be zero. (buffer-start-column (or (sb!impl::charpos target) 0) :type column) - ;; The line number we are currently on. Used for *print-lines* abrevs and - ;; to tell when sections have been split across multiple lines. + ;; The line number we are currently on. Used for *PRINT-LINES* + ;; abbreviations and to tell when sections have been split across + ;; multiple lines. (line-number 0 :type index) + ;; the value of *PRINT-LINES* captured at object creation time. We + ;; use this, instead of the dynamic *PRINT-LINES*, to avoid + ;; weirdness like + ;; (let ((*print-lines* 50)) + ;; (pprint-logical-block .. + ;; (dotimes (i 10) + ;; (let ((*print-lines* 8)) + ;; (print (aref possiblybigthings i) prettystream))))) + ;; terminating the output of the entire logical blockafter 8 lines. + (print-lines *print-lines* :type (or index null) :read-only t) ;; Stack of logical blocks in effect at the buffer start. (blocks (list (make-logical-block)) :type list) ;; Buffer holding the per-line prefix active at the buffer start. @@ -532,8 +543,10 @@ (defun fits-on-line-p (stream until force-newlines-p) (let ((available (pretty-stream-line-length stream))) - (when (and (not *print-readably*) *print-lines* - (= *print-lines* (pretty-stream-line-number stream))) + (when (and (not *print-readably*) + (pretty-stream-print-lines stream) + (= (pretty-stream-print-lines stream) + (pretty-stream-line-number stream))) (decf available 3) ; for the `` ..'' (decf available (logical-block-suffix-length (car (pretty-stream-blocks stream))))) @@ -567,7 +580,8 @@ (let ((line-number (pretty-stream-line-number stream))) (incf line-number) (when (and (not *print-readably*) - *print-lines* (>= line-number *print-lines*)) + (pretty-stream-print-lines stream) + (>= line-number (pretty-stream-print-lines stream))) (write-string " .." target) (let ((suffix-length (logical-block-suffix-length (car (pretty-stream-blocks stream))))) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 19123d1..7149082 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -419,36 +419,29 @@ ;;;; sys/select.h -(defmacro unix-fast-select (num-descriptors - read-fds write-fds exception-fds - timeout-secs &optional (timeout-usecs 0)) - #!+sb-doc - "Perform the UNIX select(2) system call." - ;; FIXME: These DECLAREs don't belong at macroexpansion time. They - ;; should be done at runtime instead. Perhaps we could just redo - ;; UNIX-FAST-SELECT as an inline function, and then all the - ;; declarations would work nicely. - #| +;;;; FIXME: Why have both UNIX-SELECT and UNIX-FAST-SELECT? + +;;; Perform the UNIX select(2) system call. +(declaim (inline unix-fast-select)) ; (used to be a macro in CMU CL) +(defun unix-fast-select (num-descriptors + read-fds write-fds exception-fds + timeout-secs &optional (timeout-usecs 0)) (declare (type (integer 0 #.fd-setsize) num-descriptors) (type (or (alien (* (struct fd-set))) null) read-fds write-fds exception-fds) (type (or null (unsigned-byte 31)) timeout-secs) (type (unsigned-byte 31) timeout-usecs)) - |# ;; FIXME: CMU CL had - ;; (optimize (speed 3) (safety 0) (inhibit-warnings 3)) - ;; in the declarations above. If they're important, they should - ;; be in a declaration inside the LET expansion, not in the - ;; macro compile-time code. - `(let ((timeout-secs ,timeout-secs)) - (with-alien ((tv (struct timeval))) - (when timeout-secs - (setf (slot tv 'tv-sec) timeout-secs) - (setf (slot tv 'tv-usec) ,timeout-usecs)) - (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set)) - (* (struct fd-set)) (* (struct timeval))) - ,num-descriptors ,read-fds ,write-fds ,exception-fds - (if timeout-secs (alien-sap (addr tv)) (int-sap 0)))))) + ;; (declare (optimize (speed 3) (safety 0) (inhibit-warnings 3))) + ;; here. Is that important for SBCL? If so, why? Profiling might tell us.. + (with-alien ((tv (struct timeval))) + (when timeout-secs + (setf (slot tv 'tv-sec) timeout-secs) + (setf (slot tv 'tv-usec) timeout-usecs)) + (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set)) + (* (struct fd-set)) (* (struct timeval))) + num-descriptors read-fds write-fds exception-fds + (if timeout-secs (alien-sap (addr tv)) (int-sap 0))))) ;;; UNIX-SELECT accepts sets of file descriptors and waits for an event ;;; to happen on one of them or to time out. diff --git a/src/compiler/target-byte-comp.lisp b/src/compiler/target-byte-comp.lisp index 436815c..8b8d977 100644 --- a/src/compiler/target-byte-comp.lisp +++ b/src/compiler/target-byte-comp.lisp @@ -95,8 +95,8 @@ (hairy-byte-function-entry-points xep))) #'<))))) -;;; Given a byte-compiled component, disassemble it to standard output. -;;; EPS is a list of the entry points. +;;; Given a byte-compiled component, disassemble it to standard +;;; output. EPS is a list of the entry points. (defun disassem-byte-component (component &optional (eps '(0))) (let* ((bytes (* (code-header-ref component sb!vm:code-code-size-slot) sb!vm:word-bytes)) @@ -114,8 +114,8 @@ ;;; Disassemble byte code from a SAP and constants vector. (defun disassem-byte-sap (sap bytes constants eps) (declare (optimize (inhibit-warnings 3))) - (/show "entering DISASSEM-BYTE-SAP" bytes constants eps) (let ((index 0)) + (declare (type index index)) (labels ((newline () (format t "~&~4D:" index)) (next-byte () @@ -124,12 +124,10 @@ (incf index) byte)) (extract-24-bits () - (/show "in EXTRACT-24-BITS") (logior (ash (next-byte) 16) (ash (next-byte) 8) (next-byte))) (extract-extended-op () - (/show "in EXTRACT-EXTENDED-OP") (let ((byte (next-byte))) (if (= byte 255) (extract-24-bits) @@ -145,7 +143,6 @@ :var 3-bits))) (extract-branch-target (byte) - (/show "in EXTRACT-BRANCH-TARGET") (if (logbitp 0 byte) (let ((disp (next-byte))) (if (logbitp 7 disp) @@ -153,18 +150,16 @@ (+ index disp))) (extract-24-bits))) (note (string &rest noise) - (format t "~12T~?" string noise)) + (format t " ~14T~?" string noise)) (get-constant (index) (if (< -1 index (length constants)) (aref constants index) ""))) (loop - (/show "at head of LOOP" index bytes) (unless (< index bytes) (return)) (when (eql index (first eps)) - (/show "in EQL INDEX (FIRST EPS) case") (newline) (pop eps) (let ((frame-size @@ -174,17 +169,20 @@ (logior (ash (next-byte) 16) (ash (next-byte) 8) (next-byte)))))) - (note "Entry point, frame-size=~D~%" frame-size))) + (note "entry point, frame-size=~D~%" frame-size))) (newline) (let ((byte (next-byte))) - (/show "at head of DISPATCH" index byte) (macrolet ((dispatch (&rest clauses) - `(cond ,@(mapcar #'(lambda (clause) - `((= (logand byte ,(caar clause)) - ,(cadar clause)) - ,@(cdr clause))) - clauses)))) + `(cond ,@(mapcar (lambda (clause) + (destructuring-bind + ((mask match) &body body) + clause + `((= (logand byte ,mask) ,match) + ,@body))) + clauses) + (t (error "disassembly failure for bytecode ~X" + byte))))) (dispatch ((#b11110000 #b00000000) (let ((op (extract-4-bit-op byte))) @@ -193,6 +191,9 @@ (let ((op (extract-4-bit-op byte))) (note "push-arg ~D" op))) ((#b11110000 #b00100000) + ;; FIXME: could use WITH-PRINT-RESTRICTIONS here and in + ;; next clause (or just in LABELS NOTE) instead of + ;; hand-rolling values in each case here (let ((*print-level* 3) (*print-lines* 2)) (note "push-const ~S" (get-constant (extract-4-bit-op byte))))) @@ -258,7 +259,6 @@ ;; if-eq (note "if-eq ~D" (extract-branch-target byte))) ((#b11111000 #b11011000) - (/show "in XOP case") ;; XOP (let* ((low-3-bits (extract-3-bit-op byte)) (xop (nth (if (eq low-3-bits :var) (next-byte) low-3-bits) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 1473562..e41e75c 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -771,7 +771,7 @@ (string (write-string note stream)) (function - (funcall note stream)))) + (funcall note stream)))) (terpri stream)) (fresh-line stream) (setf (dstate-notes dstate) nil))) @@ -1516,6 +1516,7 @@ (error "can't compile a lexical closure")) (compile nil lambda))) +;;; FIXME: Couldn't we just use COMPILE for this? (defun compiled-function-or-lose (thing &optional (name thing)) (cond ((or (symbolp thing) (and (listp thing) @@ -1544,14 +1545,14 @@ (type (or (member t) stream) stream) (type (member t nil) use-labels)) (pprint-logical-block (*standard-output* nil :per-line-prefix "; ") - (let ((fun (compiled-function-or-lose object))) - (if (typep fun 'sb!kernel:byte-function) - (sb!c:disassem-byte-fun fun) - ;; We can't detect closures, so be careful. - (disassemble-function (fun-self fun) - :stream stream - :use-labels use-labels))) - nil)) + (let ((fun (compiled-function-or-lose object))) + (if (typep fun 'sb!kernel:byte-function) + (sb!c:disassem-byte-fun fun) + ;; We can't detect closures, so be careful. + (disassemble-function (fun-self fun) + :stream stream + :use-labels use-labels))) + nil)) ;;; Disassembles the given area of memory starting at ADDRESS and ;;; LENGTH long. Note that if CODE-COMPONENT is NIL and this memory diff --git a/version.lisp-expr b/version.lisp-expr index 3114ed4..848cb89 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -16,4 +16,4 @@ ;;; four numeric fields, is used for versions which aren't released ;;; but correspond only to CVS tags or snapshots. -"0.pre7.14.flaky4.6" +"0.pre7.14.flaky4.7"