From 3bd7a97d1b11a2b0aee086ef211cae807f3dfc35 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Mon, 30 Jul 2001 19:30:33 +0000 Subject: [PATCH] 0.6.12.49: made verbose GC output report GET-INTERNAL-RUN-TIME when each GC happens, so that when you reading a log containing many verbose GC messages, you have a better chance of grokking what happened fixed POSIX-GETENV doc string after Alexey Dejneka pointed out that it was wrong 0.6.12.50: removed some #+OpenBSD stubifications, since FILE-LENGTH is no longer completely broken on OpenBSD now fixed the skip-trailing-whitespace logic in READ so it no longer requires a second Ctrl-D char to return EOF 0.6.12.51: merged MNA HANDLER-CASE patch: Since the compiler seems to be smart enough to handle it now, use lexical scoping again instead of the previous dynamic scoping workaround; and also do #+X86 (FLOAT-WAIT). 0.6.12.52: quasimerged MNA fix-GCC-warnings patch (sbcl-devel 2001-07-17), editing the source by hand also made other tweaks to fix GCC warnings fixed memory leak in wrapped_readlink() 0.6.12.53: merged MNA port of rtoy COERCE and ARRAY-ELEMENT-TYPE DEFOPTIMIZERs from CMU CL (sbcl-devel 2001-07-16) merged MNA port of rtoy irrational math fixes (sbcl-devel 2001-07-16) added MNA regression tests of irrational functions 0.6.12.54: merged MNA port of cachopo COPY-READTABLE fix (sbcl-devel 2001-07-17) merged MNA port of mai DESCRIBE-a-class fix (sbcl-devel 2001-07-17) 0.6.12.55: added distclean.sh to remove stuff like customize-target-features.lisp DEFCONSTANT *FOO* now issues a STYLE-WARNING. factored out LOOKS-LIKE-NAME-OF-SPECIAL-VAR-P to support this removed call to no-longer-defined OUTPUT-INTERPRETED-FUNCTION in PRINT-OBJECT method for INTERPRETED-FUNCTION (which will hopefully go away real soon anyway) 0.6.12.56: fixed bug 26: ARRAY-DISPLACEMENT now returns (VALUES NIL 0) for undisplaced arrays. fixed bug 55: DEFMACRO-MUNDANELY no longer ignores DOC. DEFMACRO-MUNDANELY should be in SB-INT. 0.6.12.57: set default for *DERIVE-FUNCTION-TYPES* to NIL (i.e. ANSI behavior) overrode the default within the cross-compiler, so that SBCL itself is still built the old static efficient way 0.6.12.58: fixed the DCONSING carry case in PROFILE ported CMU CL fix to FILL-POINTER-OUCH (Tim Moore's fix to Janne Rinta-Manty's bug report) added MNA fix for FIX-CORE-SOURCE-INFO --- BUGS | 40 +++++----- NEWS | 19 +++++ distclean.sh | 8 ++ make-host-2.sh | 11 ++- package-data-list.lisp-expr | 15 ++-- src/code/array.lisp | 25 +++--- src/code/defboot.lisp | 6 +- src/code/defmacro.lisp | 21 ++--- src/code/describe.lisp | 11 ++- src/code/early-target-error.lisp | 66 ++++++++-------- src/code/extensions.lisp | 7 ++ src/code/gc.lisp | 24 +++--- src/code/host-alieneval.lisp | 2 +- src/code/irrat.lisp | 149 +++++++++++++++++------------------- src/code/load.lisp | 7 -- src/code/loop.lisp | 24 +++--- src/code/macros.lisp | 4 + src/code/profile.lisp | 33 +++++--- src/code/reader.lisp | 53 +++++++------ src/code/stream.lisp | 2 +- src/code/target-eval.lisp | 2 +- src/compiler/alpha/call.lisp | 36 ++++----- src/compiler/early-c.lisp | 6 +- src/compiler/generic/core.lisp | 2 +- src/compiler/globaldb.lisp | 30 ++++---- src/compiler/ir1tran.lisp | 19 ++--- src/compiler/node.lisp | 7 +- src/compiler/srctran.lisp | 106 +++++++++++++++++++++++++ src/runtime/coreparse.c | 26 ++++--- src/runtime/gencgc.c | 4 +- src/runtime/interr.c | 2 +- src/runtime/interrupt.c | 10 ++- src/runtime/wrap.c | 12 +-- src/runtime/x86-arch.c | 1 + tests/compiler-1.impure-cload.lisp | 23 ++++++ tests/interface.pure.lisp | 2 - tests/irrat.pure.lisp | 77 +++++++++++++++++++ version.lisp-expr | 2 +- 38 files changed, 578 insertions(+), 316 deletions(-) create mode 100644 distclean.sh create mode 100644 tests/irrat.pure.lisp diff --git a/BUGS b/BUGS index cf652e8..fb0ced3 100644 --- a/BUGS +++ b/BUGS @@ -183,21 +183,6 @@ WORKAROUND: 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 @@ -281,6 +266,8 @@ WORKAROUND: 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, @@ -466,11 +453,6 @@ SBCL: (("blah") ("blah2")) 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)) @@ -1088,6 +1070,12 @@ Error in function C::GET-LAMBDA-TO-COMPILE: 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 @@ -1160,3 +1148,15 @@ IR1-4: 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. diff --git a/NEWS b/NEWS index 49cc158..a601e15 100644 --- a/NEWS +++ b/NEWS @@ -751,17 +751,36 @@ changes in sbcl-0.6.13 relative to sbcl-0.6.12: 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 diff --git a/distclean.sh b/distclean.sh new file mode 100644 index 0000000..9ba8508 --- /dev/null +++ b/distclean.sh @@ -0,0 +1,8 @@ +#!/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 diff --git a/make-host-2.sh b/make-host-2.sh index dd6751e..25be348 100644 --- a/make-host-2.sh +++ b/make-host-2.sh @@ -64,9 +64,18 @@ $SBCL_XC_HOST <<-'EOF' || exit 1 (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*)) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 81881c8..21a6d6f 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -548,7 +548,7 @@ like *STACK-TOP-HINT*" "*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 @@ -685,6 +685,11 @@ retained, possibly temporariliy, because it might be used internally." ;; 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" @@ -821,9 +826,9 @@ retained, possibly temporariliy, because it might be used internally." "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 @@ -889,7 +894,7 @@ retained, possibly temporariliy, because it might be used internally." :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")) @@ -1004,7 +1009,7 @@ is a good idea, but see SB-SYS for blurring of boundaries." "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" @@ -1069,7 +1074,7 @@ is a good idea, but see SB-SYS for blurring of boundaries." "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" diff --git a/src/code/array.lisp b/src/code/array.lisp index 9b6e9fb..f3ee81b 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -17,8 +17,8 @@ ;;;; 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) @@ -558,14 +558,14 @@ (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) @@ -579,7 +579,7 @@ (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)) @@ -589,7 +589,7 @@ (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) @@ -597,14 +597,17 @@ (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))) diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 89c3111..f91b790 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -194,7 +194,11 @@ (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)) ;;;; DEFVAR and DEFPARAMETER diff --git a/src/code/defmacro.lisp b/src/code/defmacro.lisp index eac1da5..ea41418 100644 --- a/src/code/defmacro.lisp +++ b/src/code/defmacro.lisp @@ -77,23 +77,18 @@ ;;; 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)))) diff --git a/src/code/describe.lisp b/src/code/describe.lisp index 1b6f0f2..3b650bc 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -326,7 +326,7 @@ (%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.) @@ -335,8 +335,15 @@ (%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)))) diff --git a/src/code/early-target-error.lisp b/src/code/early-target-error.lisp index 216a9fe..17a950e 100644 --- a/src/code/early-target-error.lisp +++ b/src/code/early-target-error.lisp @@ -322,13 +322,12 @@ ;;;; 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 @@ -340,52 +339,53 @@ (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)))) -;;;; 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 diff --git a/src/code/extensions.lisp b/src/code/extensions.lisp index da44a34..1ea0c92 100644 --- a/src/code/extensions.lisp +++ b/src/code/extensions.lisp @@ -538,6 +538,13 @@ (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 diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 3888348..c3a5998 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -23,20 +23,24 @@ (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)) @@ -191,7 +195,7 @@ and submit it as a patch." (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)) @@ -209,7 +213,7 @@ and submit it as a patch." (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) diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 5e1f3e5..4b75b31 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -1148,7 +1148,7 @@ ;;;; 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." diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 555c952..6d86938 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -458,7 +458,7 @@ (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))) @@ -532,12 +532,6 @@ ;; 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." @@ -549,12 +543,6 @@ (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." @@ -617,8 +605,11 @@ ((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 @@ -627,7 +618,7 @@ (optimize (speed 3) (safety 0))) (the double-float (log (the (double-float 0d0) (+ number 1d0))))) -;;;; 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 @@ -691,10 +682,8 @@ ;;; 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 @@ -711,6 +700,18 @@ (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 @@ -725,17 +726,11 @@ 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: @@ -751,46 +746,47 @@ (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 ;;; @@ -799,14 +795,18 @@ (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)))) @@ -827,7 +827,7 @@ (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). ;;; @@ -848,23 +848,21 @@ (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 ;;; @@ -881,20 +879,22 @@ (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 @@ -902,7 +902,6 @@ (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))))) @@ -912,19 +911,14 @@ ;; 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)) @@ -936,29 +930,28 @@ (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) @@ -967,7 +960,7 @@ (coerce-to-complex-type (/ (* beta rho s) den) (/ tv den) - z)))))))) + z))))))))) ;;; Compute acos z = pi/2 - asin z. ;;; diff --git a/src/code/load.lisp b/src/code/load.lisp index e0ea324..2a2559b 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -328,15 +328,8 @@ ;; 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))) diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 3ac743c..bc4202a 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -156,13 +156,13 @@ ;;;; 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) @@ -208,7 +208,7 @@ (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))) @@ -266,7 +266,7 @@ constructed. (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)) @@ -285,9 +285,7 @@ constructed. (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)) @@ -335,7 +333,7 @@ code to be loaded. (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 @@ -419,7 +417,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (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 @@ -618,7 +616,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (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 @@ -2031,12 +2029,12 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (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." diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 2bf63a6..d94900c 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -93,6 +93,10 @@ (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 diff --git a/src/code/profile.lisp b/src/code/profile.lisp index a381821..524b5fd 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -94,6 +94,7 @@ (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 ;;;; profile encapsulations @@ -176,26 +177,34 @@ ;; 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*))) @@ -445,7 +454,7 @@ Lisp process." ;;; 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 diff --git a/src/code/reader.lisp b/src/code/reader.lisp index f91d66a..77a9555 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -164,6 +164,8 @@ (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 @@ -374,10 +376,9 @@ (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*))) @@ -388,42 +389,46 @@ (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)) @@ -433,8 +438,8 @@ ;;;; 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)) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index e9af49c..39fe0f4 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -1295,7 +1295,7 @@ (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 diff --git a/src/code/target-eval.lisp b/src/code/target-eval.lisp index 775f6bb..51f445e 100644 --- a/src/code/target-eval.lisp +++ b/src/code/target-eval.lisp @@ -26,7 +26,7 @@ (: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. diff --git a/src/compiler/alpha/call.lisp b/src/compiler/alpha/call.lisp index 7998fc3..f61d9ae 100644 --- a/src/compiler/alpha/call.lisp +++ b/src/compiler/alpha/call.lisp @@ -179,7 +179,7 @@ (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) @@ -189,8 +189,6 @@ (move csp-tn res) (inst lda csp-tn (* nargs word-bytes) csp-tn)))) - - ;;; 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. @@ -565,7 +563,7 @@ default-value-8 (trace-table-entry trace-table-normal))) -;;;; 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 @@ -1046,7 +1044,7 @@ default-value-8 (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) @@ -1059,8 +1057,9 @@ default-value-8 (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) @@ -1071,14 +1070,14 @@ default-value-8 (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) @@ -1092,9 +1091,9 @@ default-value-8 (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)) @@ -1106,7 +1105,7 @@ default-value-8 (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) @@ -1154,7 +1153,7 @@ default-value-8 ;; 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) @@ -1163,11 +1162,11 @@ default-value-8 (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 @@ -1186,8 +1185,7 @@ default-value-8 (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) diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index 0222689..c748a0c 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -116,7 +116,6 @@ ;;; 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: @@ -127,10 +126,9 @@ ;; (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)) diff --git a/src/compiler/generic/core.lisp b/src/compiler/generic/core.lisp index c36c2a3..7ca4357 100644 --- a/src/compiler/generic/core.lisp +++ b/src/compiler/generic/core.lisp @@ -89,7 +89,7 @@ ;;; 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))) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index 85b84c2..e100a5f 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -1015,15 +1015,13 @@ :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 @@ -1117,7 +1115,7 @@ (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 @@ -1127,21 +1125,21 @@ :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 @@ -1164,15 +1162,15 @@ (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 diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 8c63c71..4e1bd73 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -48,19 +48,12 @@ (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.") ;;;; namespace management utilities diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 0615b21..f304f10 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -514,7 +514,10 @@ ;; :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) @@ -573,7 +576,7 @@ ;;; 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))) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index a6dbdae..96761d9 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3435,6 +3435,112 @@ (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*))))) ;;;; debuggers' little helpers diff --git a/src/runtime/coreparse.c b/src/runtime/coreparse.c index f314449..1276c07 100644 --- a/src/runtime/coreparse.c +++ b/src/runtime/coreparse.c @@ -15,12 +15,13 @@ */ #include -#include +#include #include +#include +#include #ifdef irix #include -#include #endif #include "os.h" @@ -32,7 +33,7 @@ #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; @@ -67,16 +68,17 @@ process_directory(int fd, long *ptr, int count) 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 @@ -96,15 +98,15 @@ process_directory(int fd, long *ptr, int count) 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; diff --git a/src/runtime/gencgc.c b/src/runtime/gencgc.c index 04c5d0a..7c1eeab 100644 --- a/src/runtime/gencgc.c +++ b/src/runtime/gencgc.c @@ -5369,7 +5369,7 @@ garbage_collect_generation(int generation, int raise) { 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)); @@ -5460,7 +5460,7 @@ garbage_collect_generation(int generation, int raise) * 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, diff --git a/src/runtime/interr.c b/src/runtime/interr.c index b8a863f..a5f8650 100644 --- a/src/runtime/interr.c +++ b/src/runtime/interr.c @@ -160,7 +160,7 @@ lispobj debug_print(lispobj string) 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; diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c index 61eca78..4b42d13 100644 --- a/src/runtime/interrupt.c +++ b/src/runtime/interrupt.c @@ -14,6 +14,7 @@ */ #include +#include #include #ifdef mach /* KLUDGE: #ifdef on lowercase symbols? Ick. -- WHN 19990904 */ @@ -624,12 +625,13 @@ undoably_install_low_level_interrupt_handler (int signal, 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); } diff --git a/src/runtime/wrap.c b/src/runtime/wrap.c index 9a45b23..23bc881 100644 --- a/src/runtime/wrap.c +++ b/src/runtime/wrap.c @@ -26,6 +26,7 @@ #include #include #include +#include #include #include @@ -50,17 +51,17 @@ is_lispy_filename(const char *filename) 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 @@ -112,17 +113,16 @@ free_directory_lispy_filenames(char** directory_lispy_filenames) /* 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; diff --git a/src/runtime/x86-arch.c b/src/runtime/x86-arch.c index 7ec436b..eec4f32 100644 --- a/src/runtime/x86-arch.c +++ b/src/runtime/x86-arch.c @@ -23,6 +23,7 @@ #include "interrupt.h" #include "interr.h" #include "breakpoint.h" +#include "monitor.h" #define BREAKPOINT_INST 0xcc /* INT3 */ diff --git a/tests/compiler-1.impure-cload.lisp b/tests/compiler-1.impure-cload.lisp index 1b308f9..2082d0f 100644 --- a/tests/compiler-1.impure-cload.lisp +++ b/tests/compiler-1.impure-cload.lisp @@ -77,4 +77,27 @@ (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 diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp index a7cc553..3fb1cf4 100644 --- a/tests/interface.pure.lisp +++ b/tests/interface.pure.lisp @@ -66,5 +66,3 @@ ;;; 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") diff --git a/tests/irrat.pure.lisp b/tests/irrat.pure.lisp new file mode 100644 index 0000000..2ff3b03 --- /dev/null +++ b/tests/irrat.pure.lisp @@ -0,0 +1,77 @@ +;;;; 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) + +;;;; 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))) + +;;;; 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")) diff --git a/version.lisp-expr b/version.lisp-expr index 02ec17e..15245d5 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -16,4 +16,4 @@ ;;; four numeric fields, is used for versions which aren't released ;;; but correspond only to CVS tags or snapshots. -"0.6.12.49" +"0.6.12.58" -- 1.7.10.4