From 4f64f131a7bca59d0dc8be9e74d05a7645f27e67 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Wed, 28 Feb 2001 14:04:20 +0000 Subject: [PATCH] 0.6.11.6: hacking on 0.6.11.5 patches.. ..Various FIXNUM things in ASH DERIVE-TYPE need to be TARGET-FIXNUM things. ..tweaked ASH DERIVE-TYPE to make it fit in 80 columns ..defined BECOME-DEFINED-FUNCTION-NAME and PRINT-PRETTY-ON-STREAM? to reduce cut/paste ..deleted unused %FUNCTION-HEADER-ARGLIST-SLOT and %FUNCTION-HEADER-NAME-SLOT --- package-data-list.lisp-expr | 11 +-- src/code/debug-int.lisp | 13 +--- src/code/defboot.lisp | 7 +- src/code/early-setf.lisp | 4 +- src/code/late-target-error.lisp | 4 +- src/code/pprint.lisp | 15 ++-- src/code/primordial-extensions.lisp | 12 +-- src/code/print.lisp | 36 +++------ src/code/target-alieneval.lisp | 5 +- src/compiler/byte-comp.lisp | 26 ++++--- src/compiler/early-assem.lisp | 2 +- src/compiler/eval.lisp | 8 +- src/compiler/info-functions.lisp | 9 +++ src/compiler/srctran.lisp | 141 ++++++++++++++++++----------------- src/compiler/target-disassem.lisp | 38 +++++----- src/pcl/boot.lisp | 3 - src/pcl/fast-init.lisp | 22 +++--- src/runtime/print.c | 39 +++++----- version.lisp-expr | 2 +- 19 files changed, 184 insertions(+), 213 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 663c17e..3e98854 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -779,6 +779,7 @@ retained, possibly temporariliy, because it might be used internally." "MAKE-GENSYM-LIST" "DEFCONSTANT-EQX" "ABOUT-TO-MODIFY" + "PRINT-PRETTY-ON-STREAM-P" ;; These could be moved back into SB!EXT if someone has ;; compelling reasons, but hopefully we can get by @@ -843,11 +844,6 @@ is a good idea, but see SB-SYS for blurring of boundaries." "%CLOSURE-INDEX-REF" "%COS" "%COS-QUICK" "%COSH" "%DEPOSIT-FIELD" "%DOUBLE-FLOAT" "%DPB" "%EXP" "%EXPM1" -;;; MNA: cmucl-commit: Mon, 4 Dec 2000 13:50:25 -0800 (PST) -;;; No need to export the unused symbols %function-header-arglist -;;; %function-header-name %function-header-type. -;;; "%FUNCTION-HEADER-ARGLIST" -;;; "%FUNCTION-HEADER-NAME" "%FUNCTION-HEADER-TYPE" "%HYPOT" "%INSTANCE-SET-CONDITIONAL" "%LDB" "%LOG" "%LOGB" "%LOG10" "%LOG1P" "%LONG-FLOAT" "%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE" "%MAKE-RATIO" @@ -1172,6 +1168,7 @@ is a good idea, but see SB-SYS for blurring of boundaries." "STRUCTURE-CLASS-P" "DSD-INDEX" "%INSTANCE-LAYOUT" "LAYOUT-CLOS-HASH" "%FUNCTION-TYPE" "PROCLAIM-AS-FUNCTION-NAME" + "BECOME-DEFINED-FUNCTION-NAME" "%%COMPILER-DEFSTRUCT" "%NUMERATOR" "CLASS-TYPEP" "STRUCTURE-CLASS-PRINT-FUNCTION" "DSD-READ-ONLY" "LAYOUT-INHERITS" "DD-LENGTH" "%CODE-ENTRY-POINTS" @@ -1663,8 +1660,8 @@ structure representations" "FUNCALLABLE-INSTANCE-HEADER-TYPE" "FUNCALLABLE-INSTANCE-INFO-OFFSET" "FUNCTION-ARGLIST-SLOT" "FUNCTION-CODE-OFFSET" - "FUNCTION-END-BREAKPOINT-TRAP" "FUNCTION-HEADER-ARGLIST-SLOT" - "FUNCTION-HEADER-CODE-OFFSET" "FUNCTION-HEADER-NAME-SLOT" + "FUNCTION-END-BREAKPOINT-TRAP" + "FUNCTION-HEADER-CODE-OFFSET" "FUNCTION-HEADER-NEXT-SLOT" "FUNCTION-HEADER-SELF-SLOT" "FUNCTION-HEADER-TYPE" "FUNCTION-HEADER-TYPE-SLOT" "FUNCTION-NAME-SLOT" "FUNCTION-NEXT-SLOT" "FUNCTION-POINTER-TYPE" diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 465887f..13e80e8 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -736,17 +736,8 @@ ;;; XXX Should probably check whether it has reached the bottom of the ;;; stack. ;;; -;;; XXX Should handle interrupted frames, both Lisp and C. At present it -;;; manages to find a fp trail, see linux hack below. - -;;; MNA: cmucl-commit: Mon, 6 Nov 2000 10:08:39 -0800 (PST) -;;; Upon a stack trace ambiguity in x86-call-context, choose the lisp -;;; frame in preference to the C frame as this is frame of interest. - -;;; MNA: cmucl-commit: Mon, 6 Nov 2000 09:48:00 -0800 (PST) -;;; Limit the stack trace failure warning in x86-call-context to fails for the -;;; immediate frame rather failures deeper within the search. - +;;; XXX Should handle interrupted frames, both Lisp and C. At present +;;; it manages to find a fp trail, see linux hack below. (defun x86-call-context (fp &key (depth 0)) (declare (type system-area-pointer fp) (fixnum depth)) diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 69c3e9a..4c4d897 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -169,12 +169,7 @@ (if (and (consp name) (eq (first name) 'setf)) (setf (fdocumentation (second name) 'setf) doc) (setf (fdocumentation name 'function) doc))) - (sb!c::proclaim-as-function-name name) - (if (eq (info :function :where-from name) :assumed) - (progn - (setf (info :function :where-from name) :defined) - (if (info :function :assumed-type name) - (setf (info :function :assumed-type name) nil)))) + (become-defined-function-name name) (when (or inline-expansion (info :function :inline-expansion name)) (setf (info :function :inline-expansion name) diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index d9d8081..ff87f9f 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -326,7 +326,7 @@ GET-SETF-EXPANSION directly." ;;;; DEFSETF (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) - ;;; Assign setf macro information for NAME, making all appropriate checks. + ;;; Assign SETF macro information for NAME, making all appropriate checks. (defun assign-setf-macro (name expander inverse doc) (cond ((gethash name sb!c:*setf-assumed-fboundp*) (warn @@ -341,7 +341,7 @@ GET-SETF-EXPANSION directly." (warn "defining SETF macro for DEFSTRUCT slot ~ accessor; redefining as a normal function: ~S" name) - (sb!c::proclaim-as-function-name name)) + (proclaim-as-function-name name)) ((not (eq (symbol-package name) (symbol-package 'aref))) (style-warn "defining setf macro for ~S when ~S is fbound" name `(setf ,name)))) diff --git a/src/code/late-target-error.lisp b/src/code/late-target-error.lisp index 45b4bd1..656282a 100644 --- a/src/code/late-target-error.lisp +++ b/src/code/late-target-error.lisp @@ -217,10 +217,8 @@ (if (eq val *empty-condition-slot*) (let ((actual-initargs (condition-actual-initargs condition)) (slot (find-condition-class-slot class name))) - ;; MNA: cmucl-commit: Mon, 8 Jan 2001 21:21:23 -0800 (PST) - ;; Catch missing slots in condition-reader-function, and signal an error. (unless slot - (error "Slot ~S of ~S missing." name condition)) + (error "missing slot ~S of ~S" name condition)) (dolist (initarg (condition-slot-initargs slot)) (let ((val (getf actual-initargs initarg diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index df096b1..b23a4dc 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -97,6 +97,11 @@ (declare (type posn posn) (type pretty-stream stream) (values posn)) (index-column (posn-index posn stream) stream)) + +;;; Is it OK to do pretty printing on this stream at this time? +(defun print-pretty-on-stream-p (stream) + (and (pretty-stream-p stream) + *print-pretty*)) ;;;; stream interface routines @@ -628,10 +633,6 @@ ;;;; user interface to the pretty printer -;;; MNA: cmucl-commit: Wed, 27 Dec 2000 07:42:40 -0800 (PST) -;;; pprint-newline, pprint-indent, and pprint-tab should do nothing if -;;; *print-pretty* is not true. - (defun pprint-newline (kind &optional stream) #!+sb-doc "Output a conditional newline to STREAM (which defaults to @@ -659,7 +660,7 @@ ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) - (when (and (pretty-stream-p stream) *print-pretty*) + (when (print-pretty-on-stream-p stream) (enqueue-newline stream kind))) nil) @@ -682,7 +683,7 @@ ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) - (when (and (pretty-stream-p stream) *print-pretty*) + (when (print-pretty-on-stream-p stream) (enqueue-indent stream relative-to n))) nil) @@ -707,7 +708,7 @@ ((t) *terminal-io*) ((nil) *standard-output*) (t stream)))) - (when (and (pretty-stream-p stream) *print-pretty*) + (when (print-pretty-on-stream-p stream) (enqueue-tab stream kind colnum colinc))) nil) diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index 8d0db4b..3a8a71d 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -182,15 +182,11 @@ ,expr-tmp)) (error "already bound differently: ~S"))) (t - ;;; MNA: CMU CL does not like DEFCONSTANT-EQX, - ;;; at least it does not like using EXPR-TMP-, - ;;; below. (defconstant ,symbol - ;; MNA: - ;; FIXME: this is a very ugly hack, - ;; to be able to build SBCL with CMU CL (2.4.19), - ;; because there seems to be some confusion in - ;; CMU CL about ,expr-temp at EVAL-WHEN time ... + ;; KLUDGE: This is a very ugly hack, to be able to + ;; build SBCL with CMU CL (2.4.19), because there + ;; seems to be some confusion in CMU CL about + ;; ,EXPR-TEMP at EVAL-WHEN time ... -- MNA 2000-02-23 #-cmu ,expr-tmp #+cmu ,expr ,@(when doc `(,doc))))))) diff --git a/src/code/print.lisp b/src/code/print.lisp index 5c6dd4f..3a52072 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -236,21 +236,7 @@ ;;;; support for the PRINT-UNREADABLE-OBJECT macro -;;; MNA: cmucl-commit: Mon, 1 Jan 2001 01:30:53 -0800 (PST) -;;; Correct the pretty printing by print-unreadable-object. Only attempt -;;; to print pretty when the stream is a pretty-stream (and when *print-pretty*) -;;; to ensure that all output goes to the same stream. - -;;; MNA: cmucl-commit: Wed, 27 Dec 2000 05:24:30 -0800 (PST) -;;; Have print-unreadable-object respect *print-pretty*. - -;;; Guts of print-unreadable-object. -;;; -;;; When *print-pretty* and the stream is a pretty-stream, format the object -;;; within a logical block - pprint-logical-block does not rebind the stream -;;; when it is already a pretty stream so output from the body will go to the -;;; same stream. -;;; +;;; guts of PRINT-UNREADABLE-OBJECT (defun %print-unreadable-object (object stream type identity body) (when *print-readably* (error 'print-not-readable :object object)) @@ -271,9 +257,13 @@ (write (get-lisp-obj-address object) :stream stream :radix nil :base 16) (write-char #\} stream)))) - (cond ((and (sb!pretty:pretty-stream-p stream) *print-pretty*) - (pprint-logical-block (stream nil :prefix "#<" :suffix ">") - (print-description))) + (cond ((print-pretty-on-stream-p stream) + ;; Since we're printing prettily on STREAM, format the + ;; object within a logical block. PPRINT-LOGICAL-BLOCK does + ;; not rebind the stream when it is already a pretty stream + ;; so output from the body will go to the same stream. + (pprint-logical-block (stream nil :prefix "#<" :suffix ">") + (print-description))) (t (write-string "#<" stream) (print-description) @@ -1514,14 +1504,8 @@ ;;;; other leaf objects -;;; MNA: cmucl-commit: Mon, 1 Jan 2001 03:41:18 -0800 (PST) -;;; Fix output-character to escape the char-name. Reworking quote-string -;;; to not write the delimiting quotes so that is can be used by -;;; output-character. - - -;;; If *PRINT-ESCAPE* is false, just do a WRITE-CHAR, otherwise output the -;;; character name or the character in the #\char format. +;;; If *PRINT-ESCAPE* is false, just do a WRITE-CHAR, otherwise output +;;; the character name or the character in the #\char format. (defun output-character (char stream) (if (or *print-escape* *print-readably*) (let ((name (char-name char))) diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index b59b99e..c0c4861 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -321,8 +321,9 @@ ;;;; the DEREF operator -;;; Does most of the work of the different DEREF methods. Returns two values: -;;; the type and the offset (in bits) of the refered to alien. +;;; This function does most of the work of the different DEREF +;;; methods. It returns two values: the type and the offset (in bits) +;;; of the referred-to alien. (defun deref-guts (alien indices) (declare (type alien-value alien) (type list indices) diff --git a/src/compiler/byte-comp.lisp b/src/compiler/byte-comp.lisp index fa70dfd..f8eb793 100644 --- a/src/compiler/byte-comp.lisp +++ b/src/compiler/byte-comp.lisp @@ -1229,8 +1229,8 @@ (output-push-constant segment (leaf-name leaf)) (output-do-inline-function segment 'symbol-value)))) (clambda - (let* ((refered-env (lambda-environment leaf)) - (closure (environment-closure refered-env))) + (let* ((referred-env (lambda-environment leaf)) + (closure (environment-closure referred-env))) (if (null closure) (output-push-load-time-constant segment :entry leaf) (let ((my-env (node-environment ref))) @@ -1275,18 +1275,20 @@ ((:special :global) (output-push-constant segment (global-var-name leaf)) (output-do-inline-function segment 'setf-symbol-value)))) - ;;; MNA: cmucl-commit: Tue, 26 Sep 2000 09:41:00 -0700 (PDT) - ;;; Within generate-byte-code-for-set, avoid trying to set a lexical - ;;; variable with no refs since the compiler deletes such variables. (lambda-var + ;; Note: It's important to test for whether there are any + ;; references to the variable before we actually try to set it. + ;; (Setting a lexical variable with no refs caused bugs ca. CMU + ;; CL 18c, because the compiler deletes such variables.) (cond ((leaf-refs leaf) - (unless (eql values 0) - ;; Someone wants the value, so copy it. - (output-do-xop segment 'dup)) - (output-set-lambda-var segment leaf (node-environment set))) - ;; If no-one wants the value then pop it else leave it for them. - ((eql values 0) - (output-byte-with-operand segment byte-pop-n 1))))) + (unless (eql values 0) + ;; Someone wants the value, so copy it. + (output-do-xop segment 'dup)) + (output-set-lambda-var segment leaf (node-environment set))) + ;; If no one wants the value, then pop it, else leave it + ;; for them. + ((eql values 0) + (output-byte-with-operand segment byte-pop-n 1))))) (unless (eql values 0) (checked-canonicalize-values segment cont 1))) (values)) diff --git a/src/compiler/early-assem.lisp b/src/compiler/early-assem.lisp index 0162a0c..39b33ff 100644 --- a/src/compiler/early-assem.lisp +++ b/src/compiler/early-assem.lisp @@ -26,7 +26,7 @@ ;;; sequence.) ;;; ASSEMBLY-UNIT-BITS -- the number of bits in the minimum assembly -;;; unit, (also refered to as a ``byte''). Hopefully, different +;;; unit, (also referred to as a ``byte''). Hopefully, different ;;; instruction sets won't require changing this. (defconstant assembly-unit-bits 8) (defconstant assembly-unit-mask (1- (ash 1 assembly-unit-bits))) diff --git a/src/compiler/eval.lisp b/src/compiler/eval.lisp index 79afc72..c48ca7a 100644 --- a/src/compiler/eval.lisp +++ b/src/compiler/eval.lisp @@ -843,13 +843,11 @@ (sb!c::global-var (setf (symbol-value (sb!c::global-var-name var)) value))))) -;;; This does SET-LEAF-VALUE for a lambda-var leaf. The debugger tools' +;;; This does SET-LEAF-VALUE for a LAMBDA-VAR leaf. The debugger tools' ;;; internals uses this also to set interpreted local variables. - -;;; MNA: cmucl-commit: Tue, 26 Sep 2000 09:40:37 -0700 (PDT) -;;; Within set-leaf-value-lambda-var, avoid trying to set a lexical -;;; variable with no refs since the compiler deletes such variables. (defun set-leaf-value-lambda-var (node var frame-ptr closure value) + ;; Note: We avoid trying to set a lexical variable with no refs + ;; because the compiler deletes such variables. (when (sb!c::leaf-refs var) (let ((env (sb!c::node-environment node))) (cond ((not (eq (sb!c::lambda-environment (sb!c::lambda-var-home var)) diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index 2a64481..66a8347 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -69,6 +69,15 @@ (frob :source-transform) (frob :assumed-type))) (values)) + +;;; part of what happens with DEFUN, also with some PCL stuff: +;;; Make NAME known to be a function definition. +(defun become-defined-function-name (name) + (proclaim-as-function-name name) + (when (eq (info :function :where-from name) :assumed) + (setf (info :function :where-from name) :defined) + (if (info :function :assumed-type name) + (setf (info :function :assumed-type name) nil)))) ;;;; ANSI Common Lisp functions which are defined in terms of the info ;;;; database diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 807b362..7e6a983 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -1404,25 +1404,21 @@ ) ; PROGN -;;; MNA: cmucl-commit: Wed, 3 Jan 2001 21:49:12 -0800 (PST) -;;; Rework the 'ash derive-type optimizer so better handle large negative bounds. -;;; Based on suggestions from Raymond Toy. -;;; 'ash derive type optimizer. +;;; ASH derive type optimizer ;;; -;;; Large resulting bounds are easy to generate but are not particularly -;;; useful, so an open outer bound is returned for a shift greater than 64 - -;;; the largest word size of any of the ports. Large negative shifts are also -;;; problematic as the 'ash implementation only accepts shifts greater than -;;; the most-negative-fixnum. These issues are handled by two local functions: +;;; Large resulting bounds are easy to generate but are not +;;; particularly useful, so an open outer bound is returned for a +;;; shift greater than 64 - the largest word size of any of the ports. +;;; Large negative shifts are also problematic as the ASH +;;; implementation only accepts shifts greater than +;;; MOST-NEGATIVE-FIXNUM. These issues are handled by two local +;;; functions: +;;; ASH-OUTER: Perform the shift when within an acceptable range, +;;; otherwise return an open bound. +;;; ASH-INNER: Perform the shift when within range, limited to a +;;; maximum of 64, otherwise returns the inner limit. ;;; -;;; ash-outer: performs the shift when within an acceptable range, otherwise -;;; returns an open bound. -;;; -;;; ash-inner: performs the shift when within range, limited to a maximum of -;;; 64, otherwise returns the inner limit. -;;; - ;;; KLUDGE: All this ASH optimization is suppressed under CMU CL ;;; because as of version 2.4.6 for Debian, CMU CL blows up on (ASH ;;; 1000000000 -100000000000) (i.e. ASH of two bignums yielding zero) @@ -1432,13 +1428,13 @@ #!-propagate-fun-type (defoptimizer (ash derive-type) ((n shift)) (flet ((ash-outer (n s) - (when (and (fixnump s) + (when (and (target-fixnump s) (<= s 64) - (> s most-negative-fixnum)) + (> s sb!vm:*target-most-negative-fixnum*)) (ash n s))) (ash-inner (n s) - (if (and (fixnump s) - (> s most-negative-fixnum)) + (if (and (target-fixnump s) + (> s sb!vm:*target-most-negative-fixnum*)) (ash n (min s 64)) (if (minusp n) -1 0)))) (or (let ((n-type (continuation-type n))) @@ -1447,22 +1443,26 @@ (n-high (numeric-type-high n-type))) (if (constant-continuation-p shift) (let ((shift (continuation-value shift))) - (make-numeric-type :class 'integer :complexp :real + (make-numeric-type :class 'integer + :complexp :real :low (when n-low (ash n-low shift)) :high (when n-high (ash n-high shift)))) (let ((s-type (continuation-type shift))) (when (numeric-type-p s-type) - (let ((s-low (numeric-type-low s-type)) - (s-high (numeric-type-high s-type))) - (make-numeric-type :class 'integer :complexp :real - :low (when n-low - (if (minusp n-low) - (ash-outer n-low s-high) - (ash-inner n-low s-low))) - :high (when n-high - (if (minusp n-high) - (ash-inner n-high s-low) - (ash-outer n-high s-high))))))))))) + (let* ((s-low (numeric-type-low s-type)) + (s-high (numeric-type-high s-type)) + (low-slot (when n-low + (if (minusp n-low) + (ash-outer n-low s-high) + (ash-inner n-low s-low)))) + (high-slot (when n-high + (if (minusp n-high) + (ash-inner n-high s-low) + (ash-outer n-high s-high))))) + (make-numeric-type :class 'integer + :complexp :real + :low low-slot + :high high-slot)))))))) *universal-type*)) (or (let ((n-type (continuation-type n))) (when (numeric-type-p n-type) @@ -1495,16 +1495,16 @@ (defun ash-derive-type-aux (n-type shift same-arg) (declare (ignore same-arg)) (flet ((ash-outer (n s) - (when (and (fixnump s) + (when (and (target-fixnump s) (<= s 64) - (> s most-negative-fixnum)) + (> s sb!vm:*target-most-negative-fixnum*)) (ash n s))) ;; KLUDGE: The bare 64's here should be related to ;; symbolic machine word size values somehow. (ash-inner (n s) - (if (and (fixnump s) - (> s most-negative-fixnum)) + (if (and (target-fixnump s) + (> s sb!vm:*target-most-negative-fixnum*)) (ash n (min s 64)) (if (minusp n) -1 0)))) (or (and (csubtypep n-type (specifier-type 'integer)) @@ -2583,13 +2583,13 @@ ;;;; functions into boolean operations when the size and position are constant ;;;; and the operands are fixnums. -(macrolet (;; Evaluate body with Size-Var and Pos-Var bound to expressions that - ;; evaluate to the Size and Position of the byte-specifier form - ;; Spec. We may wrap a let around the result of the body to bind +(macrolet (;; Evaluate body with SIZE-VAR and POS-VAR bound to expressions that + ;; evaluate to the SIZE and POSITION of the byte-specifier form + ;; SPEC. We may wrap a let around the result of the body to bind ;; some variables. ;; - ;; If the spec is a Byte form, then bind the vars to the subforms. - ;; otherwise, evaluate Spec and use the Byte-Size and Byte-Position. + ;; If the spec is a BYTE form, then bind the vars to the subforms. + ;; otherwise, evaluate SPEC and use the BYTE-SIZE and BYTE-POSITION. ;; The goal of this transformation is to avoid consing up byte ;; specifiers and then immediately throwing them away. (with-byte-specifier ((size-var pos-var spec) &body body) @@ -2698,7 +2698,7 @@ (deftransform %ldb ((size posn int) (fixnum fixnum integer) (unsigned-byte #.sb!vm:word-bits)) - "convert to inline logical ops" + "convert to inline logical operations" `(logand (ash int (- posn)) (ash ,(1- (ash 1 sb!vm:word-bits)) (- size ,sb!vm:word-bits)))) @@ -2706,7 +2706,7 @@ (deftransform %mask-field ((size posn int) (fixnum fixnum integer) (unsigned-byte #.sb!vm:word-bits)) - "convert to inline logical ops" + "convert to inline logical operations" `(logand int (ash (ash ,(1- (ash 1 sb!vm:word-bits)) (- size ,sb!vm:word-bits)) @@ -2721,7 +2721,7 @@ (deftransform %dpb ((new size posn int) * (unsigned-byte #.sb!vm:word-bits)) - "convert to inline logical ops" + "convert to inline logical operations" `(let ((mask (ldb (byte size 0) -1))) (logior (ash (logand new mask) posn) (logand int (lognot (ash mask posn)))))) @@ -2729,7 +2729,7 @@ (deftransform %dpb ((new size posn int) * (signed-byte #.sb!vm:word-bits)) - "convert to inline logical ops" + "convert to inline logical operations" `(let ((mask (ldb (byte size 0) -1))) (logior (ash (logand new mask) posn) (logand int (lognot (ash mask posn)))))) @@ -2737,7 +2737,7 @@ (deftransform %deposit-field ((new size posn int) * (unsigned-byte #.sb!vm:word-bits)) - "convert to inline logical ops" + "convert to inline logical operations" `(let ((mask (ash (ldb (byte size 0) -1) posn))) (logior (logand new mask) (logand int (lognot mask))))) @@ -2745,7 +2745,7 @@ (deftransform %deposit-field ((new size posn int) * (signed-byte #.sb!vm:word-bits)) - "convert to inline logical ops" + "convert to inline logical operations" `(let ((mask (ash (ldb (byte size 0) -1) posn))) (logior (logand new mask) (logand int (lognot mask))))) @@ -2767,7 +2767,7 @@ ;;; Handle the case of a constant BOOLE-CODE. (deftransform boole ((op x y) * * :when :both) - "convert to inline logical ops" + "convert to inline logical operations" (unless (constant-continuation-p op) (give-up-ir1-transform "BOOLE code is not a constant.")) (let ((control (continuation-value op))) @@ -3118,7 +3118,8 @@ ;;; If X and Y are the same leaf, then the result is true. Otherwise, if ;;; there is no intersection between the types of the arguments, then the ;;; result is definitely false. -(deftransform simple-equality-transform ((x y) * * :defun-only t +(deftransform simple-equality-transform ((x y) * * + :defun-only t :when :both) (cond ((same-leaf-ref-p x y) 't) @@ -3130,18 +3131,19 @@ (dolist (x '(eq char= equal)) (%deftransform x '(function * *) #'simple-equality-transform)) -;;; Similar to SIMPLE-EQUALITY-PREDICATE, except that we also try to convert -;;; to a type-specific predicate or EQ: -;;; -- If both args are characters, convert to CHAR=. This is better than just -;;; converting to EQ, since CHAR= may have special compilation strategies -;;; for non-standard representations, etc. -;;; -- If either arg is definitely not a number, then we can compare with EQ. -;;; -- Otherwise, we try to put the arg we know more about second. If X is -;;; constant then we put it second. If X is a subtype of Y, we put it -;;; second. These rules make it easier for the back end to match these -;;; interesting cases. -;;; -- If Y is a fixnum, then we quietly pass because the back end can handle -;;; that case, otherwise give an efficency note. +;;; Similar to SIMPLE-EQUALITY-PREDICATE, except that we also try to +;;; convert to a type-specific predicate or EQ: +;;; -- If both args are characters, convert to CHAR=. This is better than +;;; just converting to EQ, since CHAR= may have special compilation +;;; strategies for non-standard representations, etc. +;;; -- If either arg is definitely not a number, then we can compare +;;; with EQ. +;;; -- Otherwise, we try to put the arg we know more about second. If X +;;; is constant then we put it second. If X is a subtype of Y, we put +;;; it second. These rules make it easier for the back end to match +;;; these interesting cases. +;;; -- If Y is a fixnum, then we quietly pass because the back end can +;;; handle that case, otherwise give an efficency note. (deftransform eql ((x y) * * :when :both) "convert to simpler equality predicate" (let ((x-type (continuation-type x)) @@ -3309,8 +3311,10 @@ (def-source-transform char-equal (&rest args) (multi-compare 'char-equal args nil)) (def-source-transform char-lessp (&rest args) (multi-compare 'char-lessp args nil)) -(def-source-transform char-greaterp (&rest args) (multi-compare 'char-greaterp args nil)) -(def-source-transform char-not-greaterp (&rest args) (multi-compare 'char-greaterp args t)) +(def-source-transform char-greaterp (&rest args) + (multi-compare 'char-greaterp args nil)) +(def-source-transform char-not-greaterp (&rest args) + (multi-compare 'char-greaterp args t)) (def-source-transform char-not-lessp (&rest args) (multi-compare 'char-lessp args t)) ;;; This function does source transformation of N-arg inequality @@ -3374,7 +3378,7 @@ ;;; Do source transformations for transitive functions such as +. ;;; One-arg cases are replaced with the arg and zero arg cases with -;;; the identity. If Leaf-Fun is true, then replace two-arg calls with +;;; the identity. If LEAF-FUN is true, then replace two-arg calls with ;;; a call to that function. (defun source-transform-transitive (fun args identity &optional leaf-fun) (declare (symbol fun leaf-fun) (list args)) @@ -3389,9 +3393,12 @@ (def-source-transform + (&rest args) (source-transform-transitive '+ args 0)) (def-source-transform * (&rest args) (source-transform-transitive '* args 1)) -(def-source-transform logior (&rest args) (source-transform-transitive 'logior args 0)) -(def-source-transform logxor (&rest args) (source-transform-transitive 'logxor args 0)) -(def-source-transform logand (&rest args) (source-transform-transitive 'logand args -1)) +(def-source-transform logior (&rest args) + (source-transform-transitive 'logior args 0)) +(def-source-transform logxor (&rest args) + (source-transform-transitive 'logxor args 0)) +(def-source-transform logand (&rest args) + (source-transform-transitive 'logand args -1)) (def-source-transform logeqv (&rest args) (if (evenp (length args)) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 51b4bcb..33895de 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -1787,23 +1787,21 @@ ;;; routines to find things in the Lisp environment +;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUNCTION-NAME) for slots +;;; in a symbol object that we know about (defparameter *grokked-symbol-slots* (sort `((,sb!vm:symbol-value-slot . symbol-value) (,sb!vm:symbol-plist-slot . symbol-plist) (,sb!vm:symbol-name-slot . symbol-name) (,sb!vm:symbol-package-slot . symbol-package)) #'< - :key #'car) - #!+sb-doc - "An alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUNCTION-NAME) for slots in a -symbol object that we know about.") + :key #'car)) +;;; Given ADDRESS, try and figure out if which slot of which symbol is +;;; being referred to. Of course we can just give up, so it's not a +;;; big deal... Return two values, the symbol and the name of the +;;; access function of the slot. (defun grok-symbol-slot-ref (address) - #!+sb-doc - "Given ADDRESS, try and figure out if which slot of which symbol is being - refered to. Of course we can just give up, so it's not a big deal... - Returns two values, the symbol and the name of the access function of the - slot." (declare (type address address)) (if (not (aligned-p address sb!vm:word-bytes)) (values nil nil) @@ -1821,25 +1819,24 @@ symbol object that we know about.") (defvar *address-of-nil-object* (sb!kernel:get-lisp-obj-address nil)) +;;; Given a BYTE-OFFSET from NIL, try and figure out which slot of +;;; which symbol is being referred to. Of course we can just give up, +;;; so it's not a big deal... Return two values, the symbol and the +;;; access function. (defun grok-nil-indexed-symbol-slot-ref (byte-offset) - #!+sb-doc - "Given a BYTE-OFFSET from NIL, try and figure out if which slot of which - symbol is being refered to. Of course we can just give up, so it's not a big - deal... Returns two values, the symbol and the access function." (declare (type offset byte-offset)) (grok-symbol-slot-ref (+ *address-of-nil-object* byte-offset))) +;;; Return the Lisp object located BYTE-OFFSET from NIL. (defun get-nil-indexed-object (byte-offset) - #!+sb-doc - "Returns the lisp object located BYTE-OFFSET from NIL." (declare (type offset byte-offset)) (sb!kernel:make-lisp-obj (+ *address-of-nil-object* byte-offset))) +;;; Return two values; the Lisp object located at BYTE-OFFSET in the +;;; constant area of the code-object in the current segment and T, or +;;; NIL and NIL if there is no code-object in the current segment. (defun get-code-constant (byte-offset dstate) #!+sb-doc - "Returns two values; the lisp-object located at BYTE-OFFSET in the constant - area of the code-object in the current segment and T, or NIL and NIL if - there is no code-object in the current segment." (declare (type offset byte-offset) (type disassem-state dstate)) (let ((code (seg-code (dstate-segment dstate)))) @@ -1854,10 +1851,9 @@ symbol object that we know about.") (defvar *assembler-routines-by-addr* nil) +;;; Return the name of the primitive Lisp assembler routine located at +;;; ADDRESS, or NIL if there isn't one. (defun find-assembler-routine (address) - #!+sb-doc - "Returns the name of the primitive lisp assembler routine located at - ADDRESS, or NIL if there isn't one." (declare (type address address)) (when (null *assembler-routines-by-addr*) (setf *assembler-routines-by-addr* (make-hash-table)) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index f734467..af7946d 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -2057,9 +2057,6 @@ bootstrapping. (setq spec-ll (pop cdr-of-form)) (values name qualifiers spec-ll cdr-of-form))) -;;; MNA: cmucl-commit: Tue, 19 Dec 2000 06:26:31 -0800 (PST) -;;; Add a defensive declaration to PARSE-SPECIALIZERS. - (defun parse-specializers (specializers) (declare (list specializers)) (flet ((parse (spec) diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp index 9740481..f456693 100644 --- a/src/pcl/fast-init.lisp +++ b/src/pcl/fast-init.lisp @@ -60,16 +60,18 @@ (sym (make-instance-function-symbol key))) (push key *make-instance-function-keys*) (when sym - ;; MNA: cmucl-commit Sat, 27 Jan 2001 07:07:45 -0800 (PST) - ;; Silence compiler warnings about undefined function - ;; - ;; when compiling a method containing a make-instance call. - (progn ;; Lifted from c::%%defun. - (sb-c::proclaim-as-function-name sym) - (when (eq (sb-int:info :function :where-from sym) :assumed) - (setf (sb-int:info :function :where-from sym) :defined) - (when (sb-int:info :function :assumed-type sym) - (setf (sb-int:info :function :assumed-type sym) nil)))) + ;; (famous last words: + ;; 1. Don't worry, I know what I'm doing. + ;; 2. You and what army? + ;; 3. If you were as smart as you think you are, you + ;; wouldn't be a copy. + ;; This is case #1.:-) Even if SYM hasn't been defined yet, + ;; it must be an implementation function, or we we wouldn't + ;; have expanded into it. So declare SYM as defined, so that + ;; even if it hasn't been defined yet, the user doesn't get + ;; obscure warnings about undefined internal implementation + ;; functions like HAIRY-MAKE-instance-name. + (sb-kernel:become-defined-function-name sym) `(,sym ',class (list ,@initargs))))))) (defmacro expanding-make-instance-top-level (&rest forms &environment env) diff --git a/src/runtime/print.c b/src/runtime/print.c index 505c7fe..8ff85e8 100644 --- a/src/runtime/print.c +++ b/src/runtime/print.c @@ -38,7 +38,7 @@ static int cur_clock = 0; static void print_obj(char *prefix, lispobj obj); -#define NEWLINE if (continue_p(1)) newline(NULL); else return; +#define NEWLINE_OR_RETURN if (continue_p(1)) newline(NULL); else return; char *lowtag_Names[] = { "even fixnum", @@ -450,7 +450,7 @@ static void print_otherptr(lispobj obj) print_obj("header: ", header); if (LowtagOf(header) != type_OtherImmediate0 && LowtagOf(header) != type_OtherImmediate1) { - NEWLINE; + NEWLINE_OR_RETURN; printf("(invalid header object)"); return; } @@ -458,7 +458,7 @@ static void print_otherptr(lispobj obj) switch (type) { case type_Bignum: ptr += count; - NEWLINE; + NEWLINE_OR_RETURN; printf("0x"); while (count-- > 0) printf("%08lx", (unsigned long) *--ptr); @@ -477,51 +477,51 @@ static void print_otherptr(lispobj obj) break; case type_SingleFloat: - NEWLINE; + NEWLINE_OR_RETURN; printf("%g", ((struct single_float *)PTR(obj))->value); break; case type_DoubleFloat: - NEWLINE; + NEWLINE_OR_RETURN; printf("%g", ((struct double_float *)PTR(obj))->value); break; #ifdef type_LongFloat case type_LongFloat: - NEWLINE; + NEWLINE_OR_RETURN; printf("%Lg", ((struct long_float *)PTR(obj))->value); break; #endif #ifdef type_ComplexSingleFloat case type_ComplexSingleFloat: - NEWLINE; + NEWLINE_OR_RETURN; printf("%g", ((struct complex_single_float *)PTR(obj))->real); - NEWLINE; + NEWLINE_OR_RETURN; printf("%g", ((struct complex_single_float *)PTR(obj))->imag); break; #endif #ifdef type_ComplexDoubleFloat case type_ComplexDoubleFloat: - NEWLINE; + NEWLINE_OR_RETURN; printf("%g", ((struct complex_double_float *)PTR(obj))->real); - NEWLINE; + NEWLINE_OR_RETURN; printf("%g", ((struct complex_double_float *)PTR(obj))->imag); break; #endif #ifdef type_ComplexLongFloat case type_ComplexLongFloat: - NEWLINE; + NEWLINE_OR_RETURN; printf("%Lg", ((struct complex_long_float *)PTR(obj))->real); - NEWLINE; + NEWLINE_OR_RETURN; printf("%Lg", ((struct complex_long_float *)PTR(obj))->imag); break; #endif case type_SimpleString: - NEWLINE; + NEWLINE_OR_RETURN; cptr = (char *)(ptr+1); putchar('"'); while (length-- > 0) @@ -530,7 +530,7 @@ static void print_otherptr(lispobj obj) break; case type_SimpleVector: - NEWLINE; + NEWLINE_OR_RETURN; printf("length = %ld", length); ptr++; index = 0; @@ -540,11 +540,8 @@ static void print_otherptr(lispobj obj) } break; - /* MNA: cmucl-commit Tue, 9 Jan 2001 11:46:57 -0800 (PST) - Correct the printing of instance objects for which the length was - being incorrectly calculated. */ case type_InstanceHeader: - NEWLINE; + NEWLINE_OR_RETURN; printf("length = %ld", (long) count); index = 0; while (count-- > 0) { @@ -618,7 +615,7 @@ static void print_otherptr(lispobj obj) break; case type_Sap: - NEWLINE; + NEWLINE_OR_RETURN; #ifndef alpha printf("0x%08lx", (unsigned long) *ptr); #else @@ -632,7 +629,7 @@ static void print_otherptr(lispobj obj) case type_BaseChar: case type_UnboundMarker: - NEWLINE; + NEWLINE_OR_RETURN; printf("pointer to an immediate?"); break; @@ -641,7 +638,7 @@ static void print_otherptr(lispobj obj) break; default: - NEWLINE; + NEWLINE_OR_RETURN; printf("Unknown header object?"); break; } diff --git a/version.lisp-expr b/version.lisp-expr index 42493bf..a77725e 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.11.5" +"0.6.11.6" -- 1.7.10.4