?? 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.
\f
;;;; 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
;;; 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
;;; 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"
(if (typep possibly-logical-pathname 'logical-pathname)
(translate-logical-pathname possibly-logical-pathname)
possibly-logical-pathname))
-\f
-#|
-;;; 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)))
-|#
;; 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.
(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)))))
(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)))))
\f
;;;; 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.
(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))
;;; 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 ()
(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)
:var
3-bits)))
(extract-branch-target (byte)
- (/show "in EXTRACT-BRANCH-TARGET")
(if (logbitp 0 byte)
(let ((disp (next-byte)))
(if (logbitp 7 disp)
(+ 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)
"<bogus 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
(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)))
(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)))))
;; 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)
(string
(write-string note stream))
(function
- (funcall note stream))))
+ (funcall note stream))))
(terpri stream))
(fresh-line stream)
(setf (dstate-notes dstate) nil)))
(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)
(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
;;; 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"
projects / sbcl.git / commitdiff