munge12egnum
NIL
-23:
- When too many files are opened, OPEN will fail with an
- uninformative error message
- error in function OPEN: error opening #P"/tmp/foo.lisp": NIL
- instead of saying that too many files are open.
-
-26:
- reported by Sam Steingold on the cmucl-imp mailing list 12 May 2000:
- Also, there is another bug: `array-displacement' should return an
- array or nil as first value (as per ANSI CL), while CMUCL declares
- it as returning an array as first value always.
- (Actually, I think the old CMU CL version in SBCL never returns NIL,
- i.e. it's not just a declaration problem, but the definition doesn't
- behave ANSIly.)
-
27:
Sometimes (SB-EXT:QUIT) fails with
Argh! maximum interrupt nesting depth (4096) exceeded, exiting
that arbitrary functions check their argument types. (It might
make sense to add another flag (CHECKED?) to DEFKNOWN to
identify functions which *do* check their argument types.)
+ (Also, verify that the compiler handles declared function
+ return types as assertions.)
38:
DEFMETHOD doesn't check the syntax of &REST argument lists properly,
The implementation of #'+ returns its single argument without
type checking, e.g. (+ "illegal") => "illegal".
-55:
- In sbcl-0.6.7, there is no doc string for CL:PUSH, probably
- because it's defined with the DEFMACRO-MUNDANELY macro and something
- is wrong with doc string setting in that macro.
-
56:
Attempting to use COMPILE on something defined by DEFMACRO fails:
(DEFMACRO FOO (X) (CONS X X))
internal error, failed AVER:
"(COMMON-LISP:EQ (SB!C::TN-ENVIRONMENT SB!C:TN) SB!C::TN-ENV)"
+116:
+ The error message from compiling
+ (LAMBDA (X) (LET ((NIL 1)) X))
+ is
+
+
KNOWN BUGS RELATED TO THE IR1 INTERPRETER
(Note: At some point, the pure interpreter (actually a semi-pure
EVAL-WHEN is rewritten, which won't happen until after the IR1
interpreter is gone, the system's notion of what's a top-level form
and what's not will remain too confused to fix this problem.]
+
+IR1-5:
+ (not really a bug, just a wishlist thing which might be easy
+ when EVAL-WHEN is rewritten..) It might be good for the cross-compiler
+ to warn about nested EVAL-WHENs. (In ordinary compilation, they're
+ quite likely to be OK, but in cross-compiled code EVAL-WHENs
+ are a great source of confusion, so a style warning about anything
+ unusual could be helpful.)
+
+IR1-6:
+ (another wishlist thing..) Reimplement DEFMACRO to be basically
+ like DEFMACRO-MUNDANELY, just using EVAL-WHEN.
is now a supported extension again, since the consensus on
sbcl-devel was that it can be useful for ordinary development
work, not just for debugging SBCL itself.
+* The default for SB-EXT:*DERIVE-FUNCTION-TYPES* has changed to
+ NIL, i.e. ANSI behavior, i.e. the compiler now recognizes
+ that currently-defined functions might be redefined later with
+ different return types.
* Hash tables can be printed readably, as inspired by CMU CL code
of Eric Marsden and SBCL code of Martin Atzmueller.
* better error handling in CLOS method combination, thanks to
Martin Atzmueller porting Pierre Mai's CMU CL patches
* more overflow fixes for >16Mbyte I/O buffers
+* A bug in READ has been fixed, so that now a single Ctrl-D
+ character suffices to cause end-of-file on character streams.
+ In particular, now you only need one Ctrl-D at the command
+ line (not two) to exit SBCL.
+* fixed bug 26: ARRAY-DISPLACEMENT now returns (VALUES NIL 0) for
+ undisplaced arrays.
* fixed bug 107 (reported as a CMU CL bug by Erik Naggum on
comp.lang.lisp 2001-06-11): (WRITE #*101 :RADIX T :BASE 36) now
does the right thing.
* The implementation of some type tests, especially for CONDITION
types, is now tidier and maybe faster, due to CMU CL code
originally by Douglas Crosher, ported by Martin Atzmueller.
+* Some math functions have been fixed, and there are new
+ optimizers for deriving the types of COERCE and ARRAY-ELEMENT-TYPE,
+ thanks to Raymond Toy's work on CMU CL, ported by Martin Atzmueller.
+* A bug in COPY-READTABLE was fixed. (Joao Cachopo's patch to CMU
+ CL, ported to SBCL by Martin Atzmueller)
+* DESCRIBE now gives more information in some cases. (Pierre Mai's
+ patch to CMU CL, ported to SBCL by Martin Atzmueller)
+* The code in the SB-PROFILE package has been substantially
+ improved, although it's still unstable.
* There's a new slam.sh hack to shorten the edit/compile/debug
cycle for low-level changes to SBCL itself, and a new
:SB-AFTER-XC-CORE target feature to control the generation of
--- /dev/null
+#!/bin/sh
+
+# a superset of clean.sh, cleaning up not only automatically
+# generated files but other things (e.g. customization files)
+# which shouldn't be in the distribution
+
+rm customize-target-features.lisp
+sh clean.sh
(let (;; Life is simpler at genesis/cold-load time if we
;; needn't worry about byte-compiled code.
(sb!ext:*byte-compile-top-level* nil)
+ ;; In order to increase microefficiency of the target Lisp,
+ ;; enable old CMU CL defined-function-types-never-change
+ ;; optimizations. (ANSI says users aren't supposed to
+ ;; redefine our functions anyway; and developers can
+ ;; fend for themselves.)
+ #!-sb-fluid (sb!ext:*derive-function-types* t)
;; In order to reduce peak memory usage during GENESIS,
;; it helps to stuff several toplevel forms together
- ;; into the same function.
+ ;; into the same function. (This can't be the compiler
+ ;; default in general since it's non-ANSI in the case
+ ;; of e.g. some package-side-effecting forms, but it's
+ ;; safe in all the code we cross-compile.)
(sb!c::*top-level-lambda-max* 10)
;; Let the target know that we're the cross-compiler.
(*features* (cons :sb-xc *features*))
"*USE-IMPLEMENTATION-TYPES*"
"*BYTE-COMPILE-TOP-LEVEL*"
"*BYTE-COMPILE-DEFAULT*"
- "*DERIVE-FUNCTION-TYPES*" ; FIXME FIXME FIXME FIXME..
+ "*DERIVE-FUNCTION-TYPES*"
;; a special form for breaking out of our "declarations
;; are assertions" default
;; in the cross-compiler's environment
"DEF!MACRO" "DEF!METHOD" "DEF!STRUCT" "DEF!TYPE"
+ ;; other variations on DEFFOO stuff useful for bootstrapping
+ ;; and cross-compiling
+ "DEFMACRO-MUNDANELY"
+ "DEFCONSTANT-EQX"
+
;; messing with PATHNAMEs
"MAKE-TRIVIAL-DEFAULT-PATHNAME"
"PHYSICALIZE-PATHNAME"
"FEATUREP"
"FLUSH-STANDARD-OUTPUT-STREAMS"
"MAKE-GENSYM-LIST"
- "DEFCONSTANT-EQX"
"ABOUT-TO-MODIFY"
"PRINT-PRETTY-ON-STREAM-P"
+ "LOOKS-LIKE-NAME-OF-SPECIAL-VAR-P"
;; These could be moved back into SB!EXT if someone has
;; compelling reasons, but hopefully we can get by
:doc
"private: Theoretically this 'hides state and types used for package
integration' (said CMU CL architecture.tex) and that probably was and
-is a good idea, but see SB-SYS for blurring of boundaries."
+is a good idea, but see SB-SYS re. blurring of boundaries."
:use ("CL" "SB!ALIEN" "SB!ALIEN-INTERNALS" "SB!BIGNUM"
"SB!EXT" "SB!FASL" "SB!INT" "SB!SYS" "SB!GRAY")
:import-from (("SB!C-CALL" "VOID"))
"DOUBLE-FLOAT-INT-EXPONENT" "DOUBLE-FLOAT-LOW-BITS"
"DOUBLE-FLOAT-SIGNIFICAND"
"DOUBLE-FLOAT-P" "FLOAT-WAIT"
- "DYNAMIC-SPACE-FREE-POINTER"
+ "DYNAMIC-SPACE-FREE-POINTER" "DYNAMIC-USAGE"
"!DEFUN-FROM-COLLECTED-COLD-INIT-FORMS"
"ERROR-NUMBER-OR-LOSE" "FDEFINITION-OBJECT"
"FDOCUMENTATION" "FILENAME"
"MAKE-VALUES-TYPE"
"MAYBE-GC" "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS"
"MEMBER-TYPE-P" "MERGE-BITS" "MODIFIED-NUMERIC-TYPE"
- "DEFMACRO-MUNDANELY" "MUTATOR-SELF"
+ "MUTATOR-SELF"
"NAMED-TYPE" "NAMED-TYPE-NAME" "NAMED-TYPE-P"
"NATIVE-BYTE-ORDER" "NEGATE"
"NEVER-SUBTYPEP" "NIL-FUNCTION-RETURNED-ERROR"
\f
;;;; miscellaneous accessor functions
-;;; These functions are needed by the interpreter, 'cause the compiler
-;;; inlines them.
+;;; These functions are only needed by the interpreter, 'cause the
+;;; compiler inlines them.
(macrolet ((def-frob (name)
`(progn
(defun ,name (array)
(defun array-rank (array)
#!+sb-doc
- "Returns the number of dimensions of the Array."
+ "Return the number of dimensions of ARRAY."
(if (array-header-p array)
(%array-rank array)
1))
(defun array-dimension (array axis-number)
#!+sb-doc
- "Returns length of dimension Axis-Number of the Array."
+ "Returns the length of dimension AXIS-NUMBER of ARRAY."
(declare (array array) (type index axis-number))
(cond ((not (array-header-p array))
(unless (= axis-number 0)
(defun array-dimensions (array)
#!+sb-doc
- "Returns a list whose elements are the dimensions of the array"
+ "Return a list whose elements are the dimensions of the array"
(declare (array array))
(if (array-header-p array)
(do ((results nil (cons (array-dimension array index) results))
(defun array-total-size (array)
#!+sb-doc
- "Returns the total number of elements in the Array."
+ "Return the total number of elements in the Array."
(declare (array array))
(if (array-header-p array)
(%array-available-elements array)
(defun array-displacement (array)
#!+sb-doc
- "Returns values of :displaced-to and :displaced-index-offset options to
- make-array, or the defaults nil and 0 if not a displaced array."
- (declare (array array))
- (values (%array-data-vector array) (%array-displacement array)))
+ "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset
+ options to MAKE-ARRAY, or NIL and 0 if not a displaced array."
+ (declare (type array array))
+ (if (and (array-header-p array) ; if unsimple and
+ (%array-displaced-p array)) ; displaced
+ (values (%array-data-vector array) (%array-displacement array))
+ (values nil 0)))
(defun adjustable-array-p (array)
#!+sb-doc
- "Returns T if (adjust-array array...) would return an array identical
+ "Return T if (ADJUST-ARRAY ARRAY...) would return an array identical
to the argument, this happens for complex arrays."
(declare (array array))
(not (typep array 'simple-array)))
(setf (info :function :assumed-type name) nil)))
(:declared)
(:defined
- (setf (info :function :type name) (extract-function-type def))))
+ (setf (info :function :type name)
+ (extract-function-type def))
+ ;; We shouldn't need to clear this here because it should be clear
+ ;; already (cleared when the last definition was processed).
+ (aver (null (info :function :assumed-type name)))))
(sb!c::%%defun name def doc))
\f
;;;; DEFVAR and DEFPARAMETER
;;; DEFMACRO-MUNDANELY is like SB!XC:DEFMACRO, except that it doesn't
;;; have any EVAL-WHEN or IR1 magic associated with it, so it only
;;; takes effect in :LOAD-TOPLEVEL or :EXECUTE situations.
-;;;
-;;; KLUDGE: Currently this is only used for various special
-;;; circumstances in bootstrapping, but it seems to me that it might
-;;; be a good basis for reimplementation of DEFMACRO in terms of
-;;; EVAL-WHEN, which might be easier to understand than the current
-;;; approach based on IR1 magic. -- WHN 19990811
(def!macro defmacro-mundanely (name lambda-list &body body)
- `(progn
- (setf (sb!xc:macro-function ',name)
- ,(let ((whole (gensym "WHOLE-"))
+ (let ((whole (gensym "WHOLE-"))
(environment (gensym "ENVIRONMENT-")))
(multiple-value-bind (new-body local-decs doc)
(parse-defmacro lambda-list whole body name 'defmacro
:environment environment)
- (declare (ignore doc))
- `(lambda (,whole ,environment)
+ `(progn
+ (setf (sb!xc:macro-function ',name)
+ (lambda (,whole ,environment)
,@local-decs
(block ,name
- ,new-body)))))
- ',name))
+ ,new-body)))
+ (setf (fdocumentation ',name 'macro)
+ ,doc)
+ ',name))))
(%describe-function (fdefinition x) s :function x)))
;; FIXME: Print out other stuff from the INFO database:
- ;; * Does it name a type or class?
+ ;; * Does it name a type?
;; * Is it a structure accessor? (This is important since those are
;; magical in some ways, e.g. blasting the structure if you
;; redefine them.)
(%describe-doc x s 'structure "Structure")
(%describe-doc x s 'type "Type")
(%describe-doc x s 'setf "Setf macro")
+
(dolist (assoc (info :random-documentation :stuff x))
(format s
"~@:_Documentation on the ~(~A~):~@:_~A"
(car assoc)
- (cdr assoc))))
+ (cdr assoc)))
+
+ ;; Describe the associated class, if any.
+ (let ((symbol-named-class (cl:find-class x nil)))
+ (when symbol-named-class
+ (format t "~&It names a class ~A." symbol-named-class)
+ (describe symbol-named-class))))
;;;; HANDLER-CASE and IGNORE-ERRORS
(defmacro handler-case (form &rest cases)
- #!+sb-doc
"(HANDLER-CASE form
{ (type ([var]) body) }* )
- Executes form in a context with handlers established for the condition
+ Execute FORM in a context with handlers established for the condition
types. A peculiar property allows type to be :no-error. If such a clause
occurs, and form returns normally, all its values are passed to this clause
- as if by MULTIPLE-VALUE-CALL. The :no-error clause accepts more than one
+ as if by MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one
var specification."
(let ((no-error-clause (assoc ':no-error cases)))
(if no-error-clause
(return-from ,error-return
(handler-case (return-from ,normal-return ,form)
,@(remove no-error-clause cases)))))))
- (let ((var (gensym))
- (outer-tag (gensym))
- (inner-tag (gensym))
- (tag-var (gensym))
+ (let ((tag (gensym))
+ (var (gensym))
(annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
cases)))
- `(let ((,outer-tag (cons nil nil))
- (,inner-tag (cons nil nil))
- ,var ,tag-var)
- ;; FIXME: should be (DECLARE (IGNORABLE ,VAR))
- ,var ;ignoreable
- (catch ,outer-tag
- (catch ,inner-tag
- (throw ,outer-tag
+ `(block ,tag
+ (let ((,var nil))
+ (declare (ignorable ,var))
+ (tagbody
(handler-bind
,(mapcar #'(lambda (annotated-case)
- `(,(cadr annotated-case)
- #'(lambda (temp)
+ (list (cadr annotated-case)
+ `#'(lambda (temp)
,(if (caddr annotated-case)
`(setq ,var temp)
'(declare (ignore temp)))
- (setf ,tag-var
- ',(car annotated-case))
- (throw ,inner-tag nil))))
+ (go ,(car annotated-case)))))
annotated-cases)
- ,form)))
- (case ,tag-var
- ,@(mapcar #'(lambda (annotated-case)
- (let ((body (cdddr annotated-case))
- (varp (caddr annotated-case)))
- `(,(car annotated-case)
- ,@(if varp
- `((let ((,(car varp) ,var))
+ (return-from ,tag
+ #-x86 ,form
+ #+x86 (multiple-value-prog1 ,form
+ ;; Need to catch FP errors here!
+ (float-wait))))
+ ,@(mapcan
+ #'(lambda (annotated-case)
+ (list (car annotated-case)
+ (let ((body (cdddr annotated-case)))
+ `(return-from
+ ,tag
+ ,(cond ((caddr annotated-case)
+ `(let ((,(caaddr annotated-case)
+ ,var))
,@body))
- body))))
+ ((not (cdr body))
+ (car body))
+ (t
+ `(progn ,@body)))))))
annotated-cases))))))))
(defmacro ignore-errors (&rest forms)
#!+sb-doc
- "Executes forms after establishing a handler for all error conditions that
- returns from this form NIL and the condition signalled."
+ "Execute FORMS handling ERROR conditions, returning the result of the last
+ form, or (VALUES NIL the-ERROR-that-was-caught) if an ERROR was handled."
`(handler-case (progn ,@forms)
(error (condition) (values nil condition))))
\f
-;;;; helper functions for restartable error handling which couldn't be defined
-;;;; 'til now 'cause they use the RESTART-CASE macro
+;;;; helper functions for restartable error handling which couldn't be
+;;;; defined 'til now 'cause they use the RESTART-CASE macro
(defun assert-error (assertion places datum &rest arguments)
(let ((cond (if datum
(t
(error "not legal as a function name: ~S" function-name))))
+(defun looks-like-name-of-special-var-p (x)
+ (and (symbolp x)
+ (let ((name (symbol-name x)))
+ (and (> (length name) 2) ; to exclude '* and '**
+ (char= #\* (aref name 0))
+ (char= #\* (aref name (1- (length name))))))))
+
;;; ANSI guarantees that some symbols are self-evaluating. This
;;; function is to be called just before a change which would affect
;;; that. (We don't absolutely have to call this function before such
(defun ,lisp-fun ()
(sb!alien:extern-alien ,c-var-name (sb!alien:unsigned 32))))))
-#!+(or cgc gencgc) (progn
-#!-sb-fluid (declaim (inline dynamic-usage))
-(def-c-var-frob dynamic-usage "bytes_allocated"))
-
+#!-gencgc
+(progn
+ ;; This is called once per PROFILEd function call, so it's worth a
+ ;; little possible space cost to reduce its time cost.
+ #!-sb-fluid
+ (declaim (inline current-dynamic-space-start))
+ (def-c-var-frob current-dynamic-space-start "current_dynamic_space"))
+
+#!-sb-fluid
+(declaim (inline dynamic-usage)) ; to reduce PROFILEd call overhead
+#!+(or cgc gencgc)
+(def-c-var-frob dynamic-usage "bytes_allocated")
#!-(or cgc gencgc)
(defun dynamic-usage ()
(the (unsigned-byte 32)
(- (sb!sys:sap-int (sb!c::dynamic-space-free-pointer))
(current-dynamic-space-start))))
-#!-gencgc (progn
-#!-sb-fluid (declaim (inline current-dynamic-space-start))
-(def-c-var-frob current-dynamic-space-start "current_dynamic_space"))
-
(defun static-space-usage ()
(- (* sb!vm:*static-space-free-pointer* sb!vm:word-bytes)
sb!vm:static-space-start))
(defun default-gc-notify-before (notify-stream bytes-in-use)
(declare (type stream notify-stream))
(format notify-stream
- "~&; GC is beginning with ~:D bytes in use at internal runtime ~D.~%"
+ "~&; GC is beginning with ~:D bytes in use at internal runtime ~:D.~%"
bytes-in-use
(get-internal-run-time))
(finish-output notify-stream))
(declare (type stream notify-stream))
(format notify-stream
"~&; GC has finished with ~:D bytes in use (~:D bytes freed)~@
- ; at internal runtime ~D. The new GC trigger is ~:D bytes.~%"
+ ; at internal runtime ~:D. The new GC trigger is ~:D bytes.~%"
bytes-retained
bytes-freed
(get-internal-run-time)
\f
;;;; the ADDR macro
-(sb!kernel:defmacro-mundanely addr (expr &environment env)
+(defmacro-mundanely addr (expr &environment env)
#!+sb-doc
"Return an Alien pointer to the data addressed by Expr, which must be a call
to SLOT or DEREF, or a reference to an Alien variable."
(defun cis (theta)
#!+sb-doc
- "Return cos(Theta) + i sin(Theta), AKA exp(i Theta)."
+ "Return cos(Theta) + i sin(Theta), i.e. exp(i Theta)."
(declare (type real theta))
(complex (cos theta) (sin theta)))
;; error. These bad definitions also mean that sin and cos for
;; complex numbers can also lose big.
-#+nil
-(defun sinh (number)
- #!+sb-doc
- "Return the hyperbolic sine of NUMBER."
- (/ (- (exp number) (exp (- number))) 2))
-
(defun sinh (number)
#!+sb-doc
"Return the hyperbolic sine of NUMBER."
(complex (* (sinh x) (cos y))
(* (cosh x) (sin y)))))))
-#+nil
-(defun cosh (number)
- #!+sb-doc
- "Return the hyperbolic cosine of NUMBER."
- (/ (+ (exp number) (exp (- number))) 2))
-
(defun cosh (number)
#!+sb-doc
"Return the hyperbolic cosine of NUMBER."
((complex)
(complex-atanh number))))
-;;; HP-UX does not supply a C version of log1p, so
-;;; use the definition.
+;;; HP-UX does not supply a C version of log1p, so use the definition.
+;;;
+;;; FIXME: This is really not a good definition. As per Raymond Toy
+;;; working on CMU CL, "The definition really loses big-time in
+;;; roundoff as x gets small."
#!+hpux
#!-sb-fluid (declaim (inline %log1p))
#!+hpux
(optimize (speed 3) (safety 0)))
(the double-float (log (the (double-float 0d0) (+ number 1d0)))))
\f
-;;;; OLD-SPECFUN stuff
+;;;; not-OLD-SPECFUN stuff
;;;;
;;;; (This was conditional on #-OLD-SPECFUN in the CMU CL sources,
;;;; but OLD-SPECFUN was mentioned nowhere else, so it seems to be
;;; should be used instead?
(declaim (inline square))
-(declaim (ftype (function (double-float) (double-float 0d0)) square))
(defun square (x)
- (declare (double-float x)
- (values (double-float 0d0)))
+ (declare (double-float x))
(* x x))
;;; original CMU CL comment, apparently re. SCALB and LOGB and
(type double-float-exponent n))
(scale-float x n))
+;;; This is like LOGB, but X is not infinity and non-zero and not a
+;;; NaN, so we can always return an integer.
+(declaim (inline logb-finite))
+(defun logb-finite (x)
+ (declare (type double-float x))
+ (multiple-value-bind (signif exponent sign)
+ (decode-float x)
+ (declare (ignore signif sign))
+ ;; DECODE-FLOAT is almost right, except that the exponent is off
+ ;; by one.
+ (1- exponent)))
+
;;; Compute an integer N such that 1 <= |2^N * x| < 2.
;;; For the special cases, the following values are used:
;;; x logb
sb!ext:double-float-positive-infinity)
((zerop x)
;; The answer is negative infinity, but we are supposed to
- ;; signal divide-by-zero.
- ;; (error 'division-by-zero :operation 'logb :operands (list x))
+ ;; signal divide-by-zero, so do the actual division
(/ -1.0d0 x)
)
(t
- (multiple-value-bind (signif expon sign)
- (decode-float x)
- (declare (ignore signif sign))
- ;; DECODE-FLOAT is almost right, except that the exponent
- ;; is off by one.
- (1- expon)))))
+ (logb-finite x))))
;;; This function is used to create a complex number of the
;;; appropriate type:
(if (subtypep (type-of (realpart z)) 'double-float)
(complex x y)
;; Convert anything that's not a DOUBLE-FLOAT to a SINGLE-FLOAT.
- (complex (float x 1.0)
- (float y 1.0))))
+ (complex (float x 1f0)
+ (float y 1f0))))
;;; Compute |(x+i*y)/2^k|^2 scaled to avoid over/underflow. The
;;; result is r + i*k, where k is an integer.
#!+long-float (eval-when (:compile-toplevel :load-toplevel :execute)
(error "needs work for long float support"))
(defun cssqs (z)
- ;; Save all FP flags
(let ((x (float (realpart z) 1d0))
- (y (float (imagpart z) 1d0))
- (k 0)
- (rho 0d0))
- (declare (double-float x y)
- (type (double-float 0d0) rho)
- (fixnum k))
+ (y (float (imagpart z) 1d0)))
;; Would this be better handled using an exception handler to
;; catch the overflow or underflow signal? For now, we turn all
;; traps off and look at the accrued exceptions to see if any
;; signal would have been raised.
(with-float-traps-masked (:underflow :overflow)
- (setf rho (+ (square x) (square y)))
+ (let ((rho (+ (square x) (square y))))
+ (declare (optimize (speed 3) (space 0)))
(cond ((and (or (float-nan-p rho)
(float-infinity-p rho))
(or (float-infinity-p (abs x))
(float-infinity-p (abs y))))
- (setf rho sb!ext:double-float-positive-infinity))
+ (values sb!ext:double-float-positive-infinity 0))
((let ((threshold #.(/ least-positive-double-float
double-float-epsilon))
(traps (ldb sb!vm::float-sticky-bits
(sb!vm:floating-point-modes))))
- ;; overflow raised or (underflow raised and rho < lambda/eps)
+ ;; Overflow raised or (underflow raised and rho <
+ ;; lambda/eps)
(or (not (zerop (logand sb!vm:float-overflow-trap-bit traps)))
(and (not (zerop (logand sb!vm:float-underflow-trap-bit
traps)))
(< rho threshold))))
- (setf k (logb (max (abs x) (abs y))))
- (setf rho (+ (square (scalb x (- k)))
- (square (scalb y (- k))))))))
- (values rho k)))
+ ;; If we're here, neither x nor y are infinity and at
+ ;; least one is non-zero.. Thus logb returns a nice
+ ;; integer.
+ (let ((k (- (logb-finite (max (abs x) (abs y))))))
+ (values (+ (square (scalb x k))
+ (square (scalb y k)))
+ (- k))))
+ (t
+ (values rho 0)))))))
;;; principal square root of Z
;;;
(declare (number z))
(multiple-value-bind (rho k)
(cssqs z)
- (declare (type (double-float 0d0) rho)
- (fixnum k))
+ (declare (type (or (member 0d0) (double-float 0d0)) rho)
+ (type fixnum k))
(let ((x (float (realpart z) 1.0d0))
(y (float (imagpart z) 1.0d0))
(eta 0d0)
(nu 0d0))
(declare (double-float x y eta nu))
+ (locally
+ ;; space 0 to get maybe-inline functions inlined.
+ (declare (optimize (speed 3) (space 0)))
+
(if (not (float-nan-p x))
(setf rho (+ (scalb (abs x) (- k)) (sqrt rho))))
(when (< x 0d0)
(setf eta (abs nu))
(setf nu (float-sign y rho))))
- (coerce-to-complex-type eta nu z))))
+ (coerce-to-complex-type eta nu z)))))
;;; Compute log(2^j*z).
;;;
(y (float (imagpart z) 1.0d0)))
(multiple-value-bind (rho k)
(cssqs z)
- (declare (type (double-float 0d0) rho)
- (fixnum k))
+ (declare (optimize (speed 3)))
(let ((beta (max (abs x) (abs y)))
(theta (min (abs x) (abs y))))
- (declare (type (double-float 0d0) beta theta))
- (if (and (zerop k)
+ (coerce-to-complex-type (if (and (zerop k)
(< t0 beta)
(or (<= beta t1)
(< rho t2)))
- (setf rho (/ (%log1p (+ (* (- beta 1.0d0)
+ (/ (%log1p (+ (* (- beta 1.0d0)
(+ beta 1.0d0))
(* theta theta)))
- 2d0))
- (setf rho (+ (/ (log rho) 2d0)
- (* (+ k j) ln2))))
- (setf theta (atan y x))
- (coerce-to-complex-type rho theta z)))))
+ 2d0)
+ (+ (/ (log rho) 2d0)
+ (* (+ k j) ln2)))
+ (atan y x)
+ z)))))
;;; log of Z = log |Z| + i * arg Z
;;;
(defun complex-atanh (z)
(declare (number z))
(let* (;; constants
- (theta #.(/ (sqrt most-positive-double-float) 4.0d0))
- (rho #.(/ 4.0d0 (sqrt most-positive-double-float)))
- (half-pi #.(/ pi 2.0d0))
+ (theta (/ (sqrt most-positive-double-float) 4.0d0))
+ (rho (/ 4.0d0 (sqrt most-positive-double-float)))
+ (half-pi (/ pi 2.0d0))
(rp (float (realpart z) 1.0d0))
(beta (float-sign rp 1.0d0))
(x (* beta rp))
(y (* beta (- (float (imagpart z) 1.0d0))))
(eta 0.0d0)
(nu 0.0d0))
- (declare (double-float theta rho half-pi rp beta y eta nu)
- (type (double-float 0d0) x))
+ ;; Shouldn't need this declare.
+ (declare (double-float x y))
+ (locally
+ (declare (optimize (speed 3)))
(cond ((or (> x theta)
(> (abs y) theta))
- ;; to avoid overflow...
+ ;; To avoid overflow...
(setf eta (float-sign y half-pi))
;; nu is real part of 1/(x + iy). This is x/(x^2+y^2),
;; which can cause overflow. Arrange this computation so
(setf nu (let* ((x-bigger (> x (abs y)))
(r (if x-bigger (/ y x) (/ x y)))
(d (+ 1.0d0 (* r r))))
- (declare (double-float r d))
(if x-bigger
(/ (/ x) d)
(/ (/ r y) d)))))
;; tanh(176) is 1.0d0 within working precision.
(let ((t1 (+ 4d0 (square y)))
(t2 (+ (abs y) rho)))
- (declare (type (double-float 0d0) t1 t2))
- #+nil
(setf eta (log (/ (sqrt (sqrt t1)))
(sqrt t2)))
- (setf eta (* 0.5d0 (log (the (double-float 0.0d0)
- (/ (sqrt t1) t2)))))
(setf nu (* 0.5d0
(float-sign y
(+ half-pi (atan (* 0.5d0 t2))))))))
(t
(let ((t1 (+ (abs y) rho)))
- (declare (double-float t1))
- ;; normal case using log1p(x) = log(1 + x)
+ ;; Normal case using log1p(x) = log(1 + x)
(setf eta (* 0.25d0
(%log1p (/ (* 4.0d0 x)
(+ (square (- 1.0d0 x))
(square t1))))))))
(coerce-to-complex-type (* beta eta)
(- (* beta nu))
- z)))
+ z))))
;;; Compute tanh z = sinh z / cosh z.
(defun complex-tanh (z)
(declare (number z))
(let ((x (float (realpart z) 1.0d0))
(y (float (imagpart z) 1.0d0)))
- (declare (double-float x y))
+ (locally
+ ;; space 0 to get maybe-inline functions inlined
+ (declare (optimize (speed 3) (space 0)))
(cond ((> (abs x)
#-(or linux hpux) #.(/ (asinh most-positive-double-float) 4d0)
;; This is more accurate under linux.
#+(or linux hpux) #.(/ (+ (log 2.0d0)
- (log most-positive-double-float))
- 4d0))
- (complex (float-sign x)
- (float-sign y 0.0d0)))
+ (log most-positive-double-float)) 4d0))
+ (coerce-to-complex-type (float-sign x)
+ (float-sign y) z))
(t
(let* ((tv (%tan y))
(beta (+ 1.0d0 (* tv tv)))
(s (sinh x))
(rho (sqrt (+ 1.0d0 (* s s)))))
- (declare (double-float tv s)
- (type (double-float 0.0d0) beta rho))
(if (float-infinity-p (abs tv))
(coerce-to-complex-type (/ rho s)
(/ tv)
(coerce-to-complex-type (/ (* beta rho s)
den)
(/ tv den)
- z))))))))
+ z)))))))))
;;; Compute acos z = pi/2 - asin z.
;;;
;; don't. (CMU CL did, but implemented it in a non-ANSI way, and I
;; just disabled that instead of rewriting it.) -- WHN 20000131
(declare (ignore print))
-
- ;; FIXME: In sbcl-0.6.12.8 the OpenBSD implementation of FILE-LENGTH
- ;; broke because changed handling of Unix stat(2) stuff couldn't
- ;; deal with OpenBSD's 64-bit size slot. Once that's fixed, this
- ;; code can be restored.
- #!-openbsd
(when (zerop (file-length stream))
(error "attempt to load an empty FASL file:~% ~S" (namestring stream)))
-
(do-load-verbose stream verbose)
(let* ((*fasl-input-stream* stream)
(*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000)))
\f
;;;; list collection macrology
-(sb!kernel:defmacro-mundanely with-loop-list-collection-head
+(sb!int:defmacro-mundanely with-loop-list-collection-head
((head-var tail-var &optional user-head-var) &body body)
(let ((l (and user-head-var (list (list user-head-var nil)))))
`(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l)
,@body)))
-(sb!kernel:defmacro-mundanely loop-collect-rplacd
+(sb!int:defmacro-mundanely loop-collect-rplacd
(&environment env (head-var tail-var &optional user-head-var) form)
(setq form (sb!xc:macroexpand form env))
(flet ((cdr-wrap (form n)
(setq ,user-head-var (cdr ,head-var)))))
answer))))
-(sb!kernel:defmacro-mundanely loop-collect-answer (head-var
+(sb!int:defmacro-mundanely loop-collect-answer (head-var
&optional user-head-var)
(or user-head-var
`(cdr ,head-var)))
(loop-gentemp 'loop-maxmin-flag-)))
operation)
-(sb!kernel:defmacro-mundanely with-minimax-value (lm &body body)
+(sb!int:defmacro-mundanely with-minimax-value (lm &body body)
(let ((init (loop-typed-init (loop-minimax-type lm)))
(which (car (loop-minimax-operations lm)))
(infinity-data (loop-minimax-infinity-data lm))
(declare (type ,type ,answer-var ,temp-var))
,@body))))
-(sb!kernel:defmacro-mundanely loop-accumulate-minimax-value (lm
- operation
- form)
+(sb!int:defmacro-mundanely loop-accumulate-minimax-value (lm operation form)
(let* ((answer-var (loop-minimax-answer-variable lm))
(temp-var (loop-minimax-temp-variable lm))
(flag-var (loop-minimax-flag-variable lm))
(and (symbolp loop-token)
(values (gethash (symbol-name loop-token) table))))
-(sb!kernel:defmacro-mundanely loop-store-table-data (symbol table datum)
+(sb!int:defmacro-mundanely loop-store-table-data (symbol table datum)
`(setf (gethash (symbol-name ,symbol) ,table) ,datum))
(defstruct (loop-universe
(defvar *loop-desetq-temporary*
(make-symbol "LOOP-DESETQ-TEMP"))
-(sb!kernel:defmacro-mundanely loop-really-desetq (&environment env
+(sb!int:defmacro-mundanely loop-really-desetq (&environment env
&rest var-val-pairs)
(labels ((find-non-null (var)
;; see whether there's any non-null thing here
(space 1))
(+ 40 (* (- speed space) 10))))
-(sb!kernel:defmacro-mundanely loop-body (&environment env
+(sb!int:defmacro-mundanely loop-body (&environment env
prologue
before-loop
main-body
(let ((tag (gensym)))
`(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag))))))
-(sb!kernel:defmacro-mundanely loop (&environment env &rest keywords-and-forms)
+(sb!int:defmacro-mundanely loop (&environment env &rest keywords-and-forms)
(loop-standard-expansion keywords-and-forms env *loop-ansi-universe*))
-(sb!kernel:defmacro-mundanely loop-finish ()
+(sb!int:defmacro-mundanely loop-finish ()
#!+sb-doc
- "Causes the iteration to terminate \"normally\", the same as implicit
+ "Cause the iteration to terminate \"normally\", the same as implicit
termination by an iteration driving clause, or by use of WHILE or
UNTIL -- the epilogue code (if any) will be run, and any implicitly
collected result will be returned as the value of the LOOP."
(unless (symbolp name)
(error "The constant name is not a symbol: ~S" name))
(about-to-modify name)
+ (when (looks-like-name-of-special-var-p name)
+ (style-warn "defining ~S as a constant, even though the name follows~@
+the usual naming convention (names like *FOO*) for special variables"
+ name))
(let ((kind (info :variable :kind name)))
(case kind
(:constant
(total (required-argument) :type single-float :read-only t))
(defvar *overhead*)
(declaim (type overhead *overhead*))
+(makunbound '*overhead*) ; in case we reload this file when tweaking
\f
;;;; profile encapsulations
;; that as long as we only cons small amounts,
;; we'll almost always just do fixnum arithmetic.
;; (And for encapsulated functions which cons
- ;; large amounts, then we don't much care about a
- ;; single extra consed bignum.)
- (start-consing-integer (pcounter-integer nbf-pcounter))
- (start-consing-fixnum (pcounter-fixnum nbf-pcounter)))
+ ;; large amounts, then a single extra consed
+ ;; bignum tends to be proportionally negligible.)
+ (nbf0-integer (pcounter-integer nbf-pcounter))
+ (nbf0-fixnum (pcounter-fixnum nbf-pcounter))
+ (dynamic-usage-0 (sb-kernel:dynamic-usage)))
(declare (inline pcounter-or-fixnum->integer))
(multiple-value-prog1
(multiple-value-call encapsulated-fun
(sb-c:%more-arg-values arg-context
0
arg-count))
- (let ((*computing-profiling-data-for* encapsulated-fun))
+ (let ((*computing-profiling-data-for* encapsulated-fun)
+ (dynamic-usage-1 (sb-kernel:dynamic-usage)))
(setf dticks (fastbig- (get-internal-ticks) start-ticks))
(setf dconsing
- (if (eq (pcounter-integer nbf-pcounter)
- start-consing-integer)
- (- (pcounter-fixnum nbf-pcounter)
- start-consing-fixnum)
+ (if (and (eq (pcounter-integer nbf-pcounter)
+ nbf0-integer)
+ (eq (pcounter-fixnum nbf-pcounter)
+ nbf0-fixnum))
+ ;; common special case where we can avoid
+ ;; bignum arithmetic
+ (- dynamic-usage-1
+ dynamic-usage-0)
+ ;; general case
(- (get-bytes-consed)
- (+ (pcounter-integer nbf-pcounter)
- (pcounter-fixnum nbf-pcounter)))))
+ nbf0-integer
+ nbf0-fixnum
+ dynamic-usage-0)))
(setf inner-enclosed-profiles
(pcounter-or-fixnum->integer *enclosed-profiles*))
(let ((net-dticks (fastbig- dticks *enclosed-ticks*)))
;;; that I (WHN) use for my own experimentation, but it might
;;; become supported someday. Comments?)
(declaim (type unsigned-byte *timer-overhead-iterations*))
-(defvar *timer-overhead-iterations*
+(defparameter *timer-overhead-iterations*
500000)
;;; a dummy function that we profile to find profiling overhead
(mapcar #'(lambda (pair) (cons (car pair)
(copy-seq (cdr pair))))
(dispatch-tables really-from-readtable)))
+ (setf (readtable-case to-readtable)
+ (readtable-case from-readtable))
to-readtable))
(defun set-syntax-from-char (to-char from-char &optional
(eof-value nil)
(recursivep nil))
#!+sb-doc
- "Reads from stream and returns the object read, preserving the whitespace
+ "Read from STREAM and return the value read, preserving any whitespace
that followed the object."
- (cond
- (recursivep
+ (if recursivep
;; a loop for repeating when a macro returns nothing
(loop
(let ((char (read-char stream eof-error-p *eof-object*)))
(result (multiple-value-list
(funcall macrofun stream char))))
;; Repeat if macro returned nothing.
- (if result (return (car result)))))))))
- (t
+ (if result (return (car result))))))))
(let ((*sharp-equal-alist* nil))
- (read-preserving-whitespace stream eof-error-p eof-value t)))))
+ (read-preserving-whitespace stream eof-error-p eof-value t))))
;;; Return NIL or a list with one thing, depending.
;;;
;;; for functions that want comments to return so that they can look
-;;; past them. Assumes char is not whitespace.
+;;; past them. We assume CHAR is not whitespace.
(defun read-maybe-nothing (stream char)
(let ((retval (multiple-value-list
(funcall (get-cmt-entry char *readtable*) stream char))))
(if retval (rplacd retval nil))))
-(defun read (&optional (stream *standard-input*) (eof-error-p t)
- (eof-value ()) (recursivep ()))
+(defun read (&optional (stream *standard-input*)
+ (eof-error-p t)
+ (eof-value ())
+ (recursivep ()))
#!+sb-doc
- "Reads in the next object in the stream, which defaults to
- *standard-input*. For details see the I/O chapter of
- the manual."
- (prog1
- (read-preserving-whitespace stream eof-error-p eof-value recursivep)
- (let ((whitechar (read-char stream nil *eof-object*)))
- (if (and (not (eofp whitechar))
- (or (not (whitespacep whitechar))
- recursivep))
- (unread-char whitechar stream)))))
+ "Read the next Lisp value from STREAM, and return it."
+ (let ((result (read-preserving-whitespace stream
+ eof-error-p
+ eof-value
+ recursivep)))
+ ;; (This function generally discards trailing whitespace. If you
+ ;; don't want to discard trailing whitespace, call
+ ;; CL:READ-PRESERVING-WHITESPACE instead.)
+ (unless (or (eql result eof-value) recursivep)
+ (let ((next-char (read-char stream nil nil)))
+ (unless (or (null next-char)
+ (whitespacep next-char))
+ (unread-char next-char stream))))
+ result))
;;; (This is a COMMON-LISP exported symbol.)
(defun read-delimited-list (endchar &optional
(input-stream *standard-input*)
recursive-p)
#!+sb-doc
- "Reads objects from input-stream until the next character after an
- object's representation is endchar. A list of those objects read
- is returned."
+ "Read Lisp values from INPUT-STREAM until the next character after a
+ value's representation is ENDCHAR, and return the objects as a list."
(declare (ignore recursive-p))
(do ((char (flush-whitespace input-stream)
(flush-whitespace input-stream))
\f
;;;; basic readmacro definitions
;;;;
-;;;; Large, hairy subsets of readmacro definitions (backquotes and sharp
-;;;; macros) are not here, but in their own source files.
+;;;; Some large, hairy subsets of readmacro definitions (backquotes
+;;;; and sharp macros) are not here, but in their own source files.
(defun read-quote (stream ignore)
(declare (ignore ignore))
(let ((offset-current (+ start current)))
(declare (fixnum offset-current))
(if (= offset-current end)
- (let* ((new-length (* current 2))
+ (let* ((new-length (1+ (* current 2)))
(new-workspace (make-string new-length)))
(declare (simple-string new-workspace))
(%byte-blt workspace start
(:print-object
(lambda (x stream)
(print-unreadable-object (x stream :identity t)
- (sb!impl::output-interpreted-function x stream)))))
+ (interpreted-function-%name x)))))
;; The name of this interpreted function, or NIL if none specified.
(%name nil)
;; This function's debug arglist.
(trace-table-entry trace-table-normal)))
;;; Allocate a partial frame for passing stack arguments in a full
-;;; call. Nargs is the number of arguments passed. If no stack
+;;; call. NARGS is the number of arguments passed. If no stack
;;; arguments are passed, then we don't have to do anything.
(define-vop (allocate-full-call-frame)
(:info nargs)
(move csp-tn res)
(inst lda csp-tn (* nargs word-bytes) csp-tn))))
-
-\f
;;; Emit code needed at the return-point from an unknown-values call
;;; for a fixed number of values. Values is the head of the TN-Ref
;;; list for the locations that the values are to be received into.
(trace-table-entry trace-table-normal)))
\f
-;;;; Full call:
+;;;; full call:
;;;;
;;;; There is something of a cross-product effect with full calls.
;;;; Different versions are used depending on whether we know the
(move lexenv closure)))
;;; Copy a &MORE arg from the argument area to the end of the current
-;;; frame. FIXED is the number of non-more arguments.
+;;; frame. FIXED is the number of non-&MORE arguments.
(define-vop (copy-more-arg)
(:temporary (:sc any-reg :offset nl0-offset) result)
(:temporary (:sc any-reg :offset nl1-offset) count)
(do-regs (gen-label))
(done (gen-label)))
(when (< fixed register-arg-count)
- ;; Save a pointer to the results so we can fill in register args.
- ;; We don't need this if there are more fixed args than reg args.
+ ;; Save a pointer to the results so we can fill in register
+ ;; args. We don't need this if there are more fixed args than
+ ;; reg args.
(move csp-tn result))
;; Allocate the space on the stack.
(cond ((zerop fixed)
(inst ble count done)
(inst addq csp-tn count csp-tn)))
(when (< fixed register-arg-count)
- ;; We must stop when we run out of stack args, not when we run out of
- ;; more args.
+ ;; We must stop when we run out of stack args, not when we run
+ ;; out of &MORE args.
(inst subq nargs-tn (fixnumize register-arg-count) count))
;; Initialize dst to be end of stack.
(move csp-tn dst)
;; Everything of interest in registers.
(inst ble count do-regs)
- ;; Initialize src to be end of args.
+ ;; Initialize SRC to be end of args.
(inst addq cfp-tn nargs-tn src)
(emit-label loop)
(emit-label do-regs)
(when (< fixed register-arg-count)
- ;; Now we have to deposit any more args that showed up in registers.
- ;; We know there is at least one more arg, otherwise we would have
- ;; branched to done up at the top.
+ ;; Now we have to deposit any more args that showed up in
+ ;; registers. We know there is at least one &MORE arg,
+ ;; otherwise we would have branched to DONE up at the top.
(inst subq nargs-tn (fixnumize (1+ fixed)) count)
(do ((i fixed (1+ i)))
((>= i register-arg-count))
(inst subq count (fixnumize 1) count)))
(emit-label done))))
-;;; &More args are stored consecutively on the stack, starting
+;;; &MORE args are stored consecutively on the stack, starting
;;; immediately at the context pointer. The context pointer is not
;;; typed, so the lowtag is 0.
(define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg)
;; Store the value in the car (in delay slot)
(storew temp dst 0 list-pointer-type)
- ;; Dec count, and if != zero, go back for more.
+ ;; Decrement count, and if != zero, go back for more.
(inst subq count (fixnumize 1) count)
(inst bne count loop)
(emit-label done))))
;;; Return the location and size of the &MORE arg glob created by
-;;; Copy-More-Arg. Supplied is the total number of arguments supplied
+;;; COPY-MORE-ARG. Supplied is the total number of arguments supplied
;;; (originally passed in NARGS.) Fixed is the number of non-&rest
;;; arguments.
;;;
-;;; We must duplicate some of the work done by Copy-More-Arg, since at
+;;; We must duplicate some of the work done by COPY-MORE-ARG, since at
;;; that time the environment is in a pretty brain-damaged state,
;;; preventing this info from being returned as values. What we do is
;;; compute supplied - fixed, and return a pointer that many words
(inst subq supplied (fixnumize fixed) count)
(inst subq csp-tn count context)))
-
-;;; Signal wrong argument count error if Nargs isn't equal to Count.
+;;; Signal wrong argument count error if NARGS isn't equal to COUNT.
(define-vop (verify-argument-count)
(:policy :fast-safe)
(:translate sb!c::%verify-argument-count)
;;; to be called when a variable is lexically bound
(declaim (ftype (function (symbol) (values)) note-lexical-binding))
(defun note-lexical-binding (symbol)
- (let ((name (symbol-name symbol)))
;; This check is intended to protect us from getting silently
;; burned when we define
;; foo.lisp:
;; (LET ((*FOO* X))
;; (FOO 14)))
;; and then we happen to compile bar.lisp before foo.lisp.
- (when (and (char= #\* (aref name 0))
- (char= #\* (aref name (1- (length name)))))
+ (when (looks-like-name-of-special-var-p symbol)
;; FIXME: should be COMPILER-STYLE-WARNING?
(style-warn "using the lexical binding of the symbol ~S, not the~@
dynamic binding, even though the symbol name follows the usual naming~@
-convention (names like *FOO*) for special variables" symbol)))
+convention (names like *FOO*) for special variables" symbol))
(values))
;;; Backpatch all the DEBUG-INFOs dumped so far with the specified
;;; SOURCE-INFO list. We also check that there are no outstanding forward
;;; references to functions.
-(defun fix-core-source-info (info object source-info)
+(defun fix-core-source-info (info object &optional source-info)
(declare (type source-info info) (type core-object object))
(aver (zerop (hash-table-count (core-object-patch-table object))))
(let ((res (debug-source-for-info info)))
:type-spec t)
;;; where this information came from:
-;;; :DECLARED = from a declaration.
-;;; :ASSUMED = from uses of the object.
-;;; :DEFINED = from examination of the definition.
-;;; FIXME: The :DEFINED assumption that the definition won't change
-;;; isn't ANSI. KLUDGE: CMU CL uses function type information in a way
-;;; which violates its "type declarations are assertions" principle,
-;;; and SBCL has inherited that behavior. It would be really good to
-;;; fix the compiler so that it tests the return types of functions..
-;;; -- WHN ca. 19990801
+;;; :ASSUMED = from uses of the object
+;;; :DEFINED = from examination of the definition
+;;; :DECLARED = from a declaration
+;;; :DEFINED trumps :ASSUMED, and :DECLARED trumps :DEFINED.
+;;; :DEFINED and :ASSUMED are useful for issuing compile-time warnings,
+;;; and :DECLARED is useful for ANSIly specializing code which
+;;; implements the function, or which uses the function's return values.
(define-info-type
:class :function
:type :where-from
(define-info-class :variable)
-;;; The kind of variable-like thing described.
+;;; the kind of variable-like thing described
(define-info-type
:class :variable
:type :kind
:constant
:global))
-;;; The declared type for this variable.
+;;; the declared type for this variable
(define-info-type
:class :variable
:type :type
:type-spec ctype
:default *universal-type*)
-;;; Where this type and kind information came from.
+;;; where this type and kind information came from
(define-info-type
:class :variable
:type :where-from
:type-spec (member :declared :assumed :defined)
:default :assumed)
-;;; The lisp object which is the value of this constant, if known.
+;;; the Lisp object which is the value of this constant, if known
(define-info-type
:class :variable
:type :constant-value
(define-info-class :type)
-;;; The kind of type described. We return :INSTANCE for standard types that
-;;; are implemented as structures.
+;;; the kind of type described. We return :INSTANCE for standard types
+;;; that are implemented as structures.
(define-info-type
:class :type
:type :kind
:type-spec (member :primitive :defined :instance nil)
:default nil)
-;;; Expander function for a defined type.
+;;; the expander function for a defined type
(define-info-type
:class :type
:type :expander
(defvar *converting-for-interpreter* nil)
;;; FIXME: Rename to *IR1-FOR-INTERPRETER-NOT-COMPILER-P*.
-;;; FIXME: This nastiness was one of my original motivations to start
-;;; hacking CMU CL. The non-ANSI behavior can be useful, but it should
-;;; be made not the default, and perhaps should be controlled by
-;;; DECLAIM instead of a variable like this. And whether or not this
-;;; kind of checking is on, declarations should be assertions to the
-;;; extent practical, and code which can't be compiled efficiently
-;;; while adhering to that principle should give warnings.
-(defvar *derive-function-types* t
- #!+sb-doc
- "(Caution: Soon, this might change its semantics somewhat, or even go away.)
- If true, argument and result type information derived from compilation of
- DEFUNs is used when compiling calls to that function. If false, only
- information from FTYPE proclamations will be used.")
+(defvar *derive-function-types* nil
+ "Should the compiler assume that function types will never change,
+ so that it can use type information inferred from current definitions
+ to optimize code which uses those definitions? Setting this true
+ gives non-ANSI, early-CMU-CL behavior. It can be useful for improving
+ the efficiency of stable code.")
\f
;;;; namespace management utilities
;; :DECLARED, from a declaration.
;; :ASSUMED, from uses of the object.
;; :DEFINED, from examination of the definition.
- ;; FIXME: This should be a named type. (LEAF-WHERE-FROM?)
+ ;; FIXME: This should be a named type. (LEAF-WHERE-FROM? Or
+ ;; perhaps just WHERE-FROM, since it's not just used in LEAF,
+ ;; but also in various DEFINE-INFO-TYPEs in globaldb.lisp,
+ ;; and very likely elsewhere too.)
(where-from :assumed :type (member :declared :assumed :defined))
;; list of the REF nodes for this leaf
(refs () :type list)
;;; defined in the same compilation block, or that have inline
;;; expansions, or have a non-NIL INLINEP value. Whenever we change
;;; the INLINEP state (i.e. an inline proclamation) we copy the
-;;; structure so that former inlinep values are preserved.
+;;; structure so that former INLINEP values are preserved.
(def!struct (defined-function (:include global-var
(where-from :defined)
(kind :global-function)))
(declare (ignore tee))
(funcall control *standard-output* ,@arg-names)
nil)))
+
+(defoptimizer (coerce derive-type) ((value type))
+ (let ((value-type (continuation-type value))
+ (type-type (continuation-type type)))
+ #!+sb-show (format t "~&coerce-derive-type value-type ~A type-type ~A~%"
+ value-type type-type)
+ (labels
+ ((good-cons-type-p (cons-type)
+ ;; Make sure the cons-type we're looking at is something
+ ;; we're prepared to handle which is basically something
+ ;; that array-element-type can return.
+ (or (and (member-type-p cons-type)
+ (null (rest (member-type-members cons-type)))
+ (null (first (member-type-members cons-type))))
+ (let ((car-type (cons-type-car-type cons-type)))
+ (and (member-type-p car-type)
+ (null (rest (member-type-members car-type)))
+ (or (symbolp (first (member-type-members car-type)))
+ (numberp (first (member-type-members car-type)))
+ (and (listp (first (member-type-members car-type)))
+ (numberp (first (first (member-type-members
+ car-type))))))
+ (good-cons-type-p (cons-type-cdr-type cons-type))))))
+ (unconsify-type (good-cons-type)
+ ;; Convert the "printed" respresentation of a cons
+ ;; specifier into a type specifier. That is, the specifier
+ ;; (cons (eql signed-byte) (cons (eql 16) null)) is
+ ;; converted to (signed-byte 16).
+ (cond ((or (null good-cons-type)
+ (eq good-cons-type 'null))
+ nil)
+ ((and (eq (first good-cons-type) 'cons)
+ (eq (first (second good-cons-type)) 'member))
+ `(,(second (second good-cons-type))
+ ,@(unconsify-type (caddr good-cons-type))))))
+ (coerceable-p (c-type)
+ ;; Can the value be coerced to the given type? Coerce is
+ ;; complicated, so we don't handle every possible case
+ ;; here---just the most common and easiest cases:
+ ;;
+ ;; o Any real can be coerced to a float type.
+ ;; o Any number can be coerced to a complex single/double-float.
+ ;; o An integer can be coerced to an integer.
+ (let ((coerced-type c-type))
+ (or (and (subtypep coerced-type 'float)
+ (csubtypep value-type (specifier-type 'real)))
+ (and (subtypep coerced-type
+ '(or (complex single-float)
+ (complex double-float)))
+ (csubtypep value-type (specifier-type 'number)))
+ (and (subtypep coerced-type 'integer)
+ (csubtypep value-type (specifier-type 'integer))))))
+ (process-types (type)
+ ;; FIXME
+ ;; This needs some work because we should be able to derive
+ ;; the resulting type better than just the type arg of
+ ;; coerce. That is, if x is (integer 10 20), the (coerce x
+ ;; 'double-float) should say (double-float 10d0 20d0)
+ ;; instead of just double-float.
+ (cond ((member-type-p type)
+ (let ((members (member-type-members type)))
+ (if (every #'coerceable-p members)
+ (specifier-type `(or ,@members))
+ *universal-type*)))
+ ((and (cons-type-p type)
+ (good-cons-type-p type))
+ (let ((c-type (unconsify-type (type-specifier type))))
+ (if (coerceable-p c-type)
+ (specifier-type c-type)
+ *universal-type*)))
+ (t
+ *universal-type*))))
+ (cond ((union-type-p type-type)
+ (apply #'type-union (mapcar #'process-types
+ (union-type-types type-type))))
+ ((or (member-type-p type-type)
+ (cons-type-p type-type))
+ (process-types type-type))
+ (t
+ *universal-type*)))))
+
+(defoptimizer (array-element-type derive-type) ((array))
+ (let* ((array-type (continuation-type array)))
+ #!+sb-show
+ (format t "~& defoptimizer array-elt-derive-type - array-element-type ~~
+~A~%" array-type)
+ (labels ((consify (list)
+ (if (endp list)
+ '(eql nil)
+ `(cons (eql ,(car list)) ,(consify (rest list)))))
+ (get-element-type (a)
+ (let ((element-type (type-specifier
+ (array-type-specialized-element-type a))))
+ (cond ((symbolp element-type)
+ (make-member-type :members (list element-type)))
+ ((consp element-type)
+ (specifier-type (consify element-type)))
+ (t
+ (error "Can't grok type ~A~%" element-type))))))
+ (cond ((array-type-p array-type)
+ (get-element-type array-type))
+ ((union-type-p array-type)
+ (apply #'type-union
+ (mapcar #'get-element-type (union-type-types array-type))))
+ (t
+ *universal-type*)))))
\f
;;;; debuggers' little helpers
*/
#include <stdio.h>
-#include <sys/types.h>
+#include <stdlib.h>
#include <sys/file.h>
+#include <sys/types.h>
+#include <unistd.h>
#ifdef irix
#include <fcntl.h>
-#include <stdlib.h>
#endif
#include "os.h"
#include "sbcl.h"
static void
-process_directory(int fd, long *ptr, int count)
+process_directory(int fd, u32 *ptr, int count)
{
struct ndir_entry *entry;
case DYNAMIC_SPACE_ID:
#ifdef GENCGC
if (addr != (os_vm_address_t)DYNAMIC_SPACE_START) {
- fprintf(stderr, "in core: 0x%x - in runtime: 0x%x \n",
- addr, (os_vm_address_t)DYNAMIC_SPACE_START);
+ fprintf(stderr, "in core: 0x%lx; in runtime: 0x%lx \n",
+ (long)addr, (long)DYNAMIC_SPACE_START);
lose("core/runtime address mismatch: DYNAMIC_SPACE_START");
}
#else
if ((addr != (os_vm_address_t)DYNAMIC_0_SPACE_START) &&
(addr != (os_vm_address_t)DYNAMIC_1_SPACE_START)) {
- fprintf(stderr, "in core: 0x%x - in runtime: 0x%x or 0x%x\n",
- addr, (os_vm_address_t)DYNAMIC_0_SPACE_START,
- (os_vm_address_t)DYNAMIC_1_SPACE_START);
+ fprintf(stderr, "in core: 0x%lx; in runtime: 0x%lx or 0x%lx\n",
+ (long)addr,
+ (long)DYNAMIC_0_SPACE_START,
+ (long)DYNAMIC_1_SPACE_START);
lose("warning: core/runtime address mismatch: DYNAMIC_SPACE_START");
}
#endif
break;
case STATIC_SPACE_ID:
if (addr != (os_vm_address_t)STATIC_SPACE_START) {
- fprintf(stderr, "in core: 0x%p - in runtime: 0x%x\n",
- addr, (os_vm_address_t)STATIC_SPACE_START);
+ fprintf(stderr, "in core: 0x%lx - in runtime: 0x%lx\n",
+ (long)addr, (long)STATIC_SPACE_START);
lose("core/runtime address mismatch: STATIC_SPACE_START");
}
break;
case READ_ONLY_SPACE_ID:
if (addr != (os_vm_address_t)READ_ONLY_SPACE_START) {
- fprintf(stderr, "in core: 0x%x - in runtime: 0x%x\n",
- addr, (os_vm_address_t)READ_ONLY_SPACE_START);
+ fprintf(stderr, "in core: 0x%lx - in runtime: 0x%lx\n",
+ (long)addr, (long)READ_ONLY_SPACE_START);
lose("core/runtime address mismatch: READ_ONLY_SPACE_START");
}
break;
{
unsigned long bytes_freed;
unsigned long i;
- unsigned long read_only_space_size, static_space_size;
+ unsigned long static_space_size;
gc_assert(generation <= (NUM_GENERATIONS-1));
* please submit a patch. */
#if 0
if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
- read_only_space_size =
+ unsigned long read_only_space_size =
(lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) -
(lispobj*)READ_ONLY_SPACE_START;
FSHOW((stderr,
that %primitive print is used (it's only a debugging aid anyway)
we just put guarantee our safety by putting an unused buffer on
the stack before doing anything else here */
- char untouched[32];
+ char untouched[32]; /* GCC warns about not using this, but that's the point.. */
fprintf(stderr, "%s\n",
(char *)(((struct vector *)native_pointer(string))->data),untouched);
return NIL;
*/
#include <stdio.h>
+#include <stdlib.h>
#include <signal.h>
#ifdef mach /* KLUDGE: #ifdef on lowercase symbols? Ick. -- WHN 19990904 */
sigaddset_blockable(&sa.sa_mask);
sa.sa_flags = SA_SIGINFO | SA_RESTART;
- /* In the case of interrupt handlers which are modified
- * more than once, we only save the original unmodified
- * copy. */
+ /* In the case of interrupt handlers which are modified more than
+ * once, we only save the original unmodified copy. */
if (!old_low_level_signal_handler_state->was_modified) {
+ struct sigaction *old_handler =
+ (struct sigaction*) &old_low_level_signal_handler_state->handler;
old_low_level_signal_handler_state->was_modified = 1;
- sigaction(signal, &sa, &old_low_level_signal_handler_state->handler);
+ sigaction(signal, &sa, old_handler);
} else {
sigaction(signal, &sa, NULL);
}
#include <sys/types.h>
#include <dirent.h>
#include <sys/stat.h>
+#include <stdlib.h>
#include <string.h>
#include <unistd.h>
char**
alloc_directory_lispy_filenames(const char *directory_name)
{
- DIR *dir_ptr;
+ DIR *dir_ptr = opendir(directory_name);
char **result = 0;
- if (dir_ptr = opendir(directory_name)) { /* if opendir success */
+ if (dir_ptr) { /* if opendir success */
struct voidacc va;
if (0 == voidacc_ctor(&va)) { /* if voidacc_ctor success */
struct dirent *dirent_ptr;
- while (dirent_ptr = readdir(dir_ptr)) { /* until end of data */
+ while ( (dirent_ptr = readdir(dir_ptr)) ) { /* until end of data */
char* original_name = dirent_ptr->d_name;
if (is_lispy_filename(original_name)) {
/* strdup(3) is in Linux and *BSD. If you port
/* a wrapped version of readlink(2):
* -- If path isn't a symlink, or is a broken symlink, return 0.
* -- If path is a symlink, return a newly allocated string holding
- * the thing it's linked to.
- */
+ * the thing it's linked to. */
char *
wrapped_readlink(char *path)
{
- int strlen_path = strlen(path);
int bufsiz = strlen(path) + 16;
while (1) {
char *result = malloc(bufsiz);
int n_read = readlink(path, result, n_read);
if (n_read < 0) {
+ free(result);
return 0;
} else if (n_read < bufsiz) {
result[n_read] = 0;
#include "interrupt.h"
#include "interr.h"
#include "breakpoint.h"
+#include "monitor.h"
#define BREAKPOINT_INST 0xcc /* INT3 */
(0 "GMT" . "GDT") (-2 "MET" . "MET DST"))
"*The string representations of the time zones.")
+;;; The old CMU CL Python compiler assumed that it was safe to infer
+;;; function types (including return types) from function definitions
+;;; and then use them to optimize code later. This is of course bad
+;;; when functions are redefined. The problem was fixed in
+;;; sbcl-0.6.12.57.
+(defun foo (x)
+ (if (plusp x)
+ 1.0
+ 0))
+(defun bar (x)
+ (typecase (foo x)
+ (fixnum :fixnum)
+ (real :real)
+ (string :string)
+ (t :t)))
+(assert (eql (bar 11) :real))
+(assert (eql (bar -11) :fixnum))
+(setf (symbol-function 'foo) #'identity)
+(assert (eql (bar 11) :fixnum))
+(assert (eql (bar -11.0) :real))
+(assert (eql (bar "this is a test") :string))
+(assert (eql (bar (make-hash-table)) :t))
+
(sb-ext:quit :unix-status 104) ; success
;;; FIXME: It would probably be good to require here that every
;;; external symbol either has a doc string or has some good excuse
;;; (like being an accessor for a structure which has a doc string).
-
-(print "done with interface.pure.lisp")
--- /dev/null
+;;;; tests of irrational floating point functions
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package :cl-user)
+\f
+;;;; old bugs
+
+;;; This used to fail with
+;;; The value -0.44579905382680446d0 is not of type (DOUBLE-FLOAT 0.0d0).
+;;; MNA's port of Raymond Toy work on CMU CL fixed this in sbcl-0.6.12.53.
+(assert (equal (log #c(0.4 0.5)) #C(-0.44579905 0.8960554)))
+\f
+;;;; other tests
+
+;;; expt
+(assert (equal (expt #c(0 1) 2) -1))
+(assert (equal (prin1-to-string (expt 2 #c(0 1))) "#C(0.7692389 0.63896126)"))
+
+;;; log
+(assert (equal (prin1-to-string (log -3 10)) "#C(0.47712126 1.3643764)"))
+(assert (= (log 3 0) 0))
+
+;;; sqrt, isqrt
+(assert (= (sqrt 9) 3.0))
+(assert (= (sqrt -9.0) #c(0.0 3.0)))
+(assert (= (isqrt 9) 3))
+(assert (= (isqrt 26) 5))
+
+
+;;; sin, sinh, asin, asinh
+(assert (equal (prin1-to-string (sin (* 8 (/ pi 2)))) "-4.898425415289509d-16"))
+(assert (equal (prin1-to-string (sin (expt 10 3))) "0.82687956"))
+(assert (= (sinh 0) 0.0))
+(assert (equal (prin1-to-string (sinh #c(5.0 -9.6)))
+ "#C(-73.06699 12.936809)"))
+(assert (= (sin (* #c(0 1) 5)) (* #c(0 1) (sinh 5))))
+(assert (= (sinh (* #c(0 1) 5)) (* #c(0 1) (sin 5))))
+(assert (equal (prin1-to-string (asin -1)) "-1.5707964"))
+(assert (= (asin 0) 0.0))
+(assert (= (asin 2) #c(1.5707964 -1.3169578)))
+(assert (equal (prin1-to-string (asinh 0.5)) "0.4812118"))
+(assert (equal (prin1-to-string (asinh 3/7)) "0.41643077"))
+
+;;; cos, cosh, acos, acosh
+(assert (= (cos 0) 1.0))
+(assert (equal (prin1-to-string (cos (/ pi 2))) "6.123031769111886d-17"))
+(assert (= (cosh 0) 1.0))
+(assert (equal (prin1-to-string (cosh 1)) "1.5430807"))
+(assert (= (cos (* #c(0 1) 5)) (cosh 5)))
+(assert (= (cosh (* #c(0 1) 5)) (cos 5)))
+(assert (equal (prin1-to-string (acos 0)) "1.5707964"))
+(assert (equal (prin1-to-string (acos -1)) "3.1415927"))
+(assert (equal (prin1-to-string (acos 2)) "#C(0.0 1.3169578)"))
+(assert (= (acos 1.00001) #c(0.0 0.0044751678)))
+(assert (= (acosh 0) #c(0 1.5707964)))
+(assert (= (acosh 1) 0))
+(assert (= (acosh -1) #c(0 3.1415927)))
+
+;;; tan, tanh
+(assert (equal (prin1-to-string (tan 1)) "1.5574077"))
+(assert (equal (prin1-to-string (tan (/ pi 2))) "1.6331778728383844d+16"))
+(assert (equal (prin1-to-string (tanh 0.00753)) "0.0075298576"))
+(assert (= (tanh 50) 1.0))
+(assert (= (tan (* #c(0 1) 5)) (* #c(0 1) (tanh 5))))
+(assert (= (atan 1) 0.7853982))
+(assert (equal (prin1-to-string (atanh 0.5) ) "0.54930615"))
+(assert (equal (prin1-to-string (atanh 3/7)) "0.45814538"))
;;; four numeric fields, is used for versions which aren't released
;;; but correspond only to CVS tags or snapshots.
-"0.6.12.49"
+"0.6.12.58"
projects / sbcl.git / commitdiff